C          GENOPTICS - A GENERAL OPTICAL SYSTEMS EVALUATION PROGRAM     00000100
C                                                                       00000200
C          THIS VERSION ADAPTED FOR THE IBM 3081 USING MVT              00000300
C                                                                       00000400
C          GRAPHICS MODIFIED TO USE THE ZETA PLOT PACKAGE               00000500
C                                                                       00000600
C          ROUTINE STRUCTURE OF GENOPTICS     IBM 3081 VERSION          00000700
C                                                                       00000800
C     MAIN   - CARD INPUT AND DECODING ROUTINE                          00000900
C     BESJN  - CALCULATES BESSEL FUNCTIONS FOR MTF                      00001000
C     CNTCOM - COUNTS THE NUMBER OF COMMAS IN A CARD IMAGE              00001100
C     FINDE  - DECODES ONE FLOATING POINT NUMBER FROM CARD IMAGES       00001200
C     FINRAY - CREATES RAY LATTICE WITH RAYS COVERING EQUAL SOLID ANGLES00001300
C     FLOTIN - DECODES PART OF A CARD IMAGE INTO FLOATING POINT ARRAY   00001400
C     FOCUS  - DETERMINES IMAGE POSITION FOR MINIMUM SPOT SIZE          00001500
C     FREARA - FLOATING POINT DECODE MONITOR ROUTINE                    00001600
C     HEADIN - LEADS PAGES WITH PAGE HEADING INFORMATION                00001700
C     LENSCL - SCALES THE CURRENT LENS SYSTEM BY A USER-SPECIFIED FACTOR00001800
C     MAVEC  - PERFORMS VECTOR-MATRIX MULTIPLICATION                    00001900
C     MTF    - MTF (MULTIPLE TRANSFER FUNCTION)                         00002000
C     PARAX  - PERFORMS PARAXIAL RAY TRACE                              00002100
C     PREPRT - PRINTS A PRESCRIPTION MATRIX                             00002200
C     RED    - COMPUTES   RED (RADIAL ENERGY DISTRIBUTION)              00002300
C     ROTM   - CONSTRUCTS MATRIX FOR ROTATION TRANSFORMATIONS           00002400
C     SKEW   - PERFORMS REAL RAY TRACE OF SPECIFIED RAYS                00002500
C     SRFSAG - COMPUTES THE SAG OF A ROTATIONALLY SYMMETRIC SURFACE     00002600
C     SURFNO - COMPUTES THE SURFACE NO. TO WHICH INPUT DATA CARD APPLIES00002700
C                                                                       00002800
C     SURTYP -                                                          00002900
C       THIS ROUTINE IS CALLED FROM PARAX AND ADDS THE CAPABILITY       00003000
C       OF HANDLING SURFACES ENTIRELY DESCRIBED BY A POLYNOMIAL         00003100
C       EXPRESSION AND CONIC SURFACES WHICH HAVE DEFORMATION CONSTANTS  00003200
C     GRAPH -                                                           00003300
C                ROUTINE GRAPH PLOTS SPOT,RED, AND MTF DATA             00003400
C     FNDSPT -                                                          00003500
C                ROUTINE SPOT PERFORMS SPOT PLOT AND PRINT              00003600
C                CALCULATIONS                                           00003700
C                                                                       00003800
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00003900
C                                                                       00004000
C         SOME FLAGS - USED TO CONTROL CALCULATION INTERNALLY           00004100
C                        SET ACCORDING TO INPUT                         00004200
C                                                                       00004300
C             IFLAG  - STORAGE FLAG FOR  HXINIT, HXDEL, HYINIT, HYDEL   00004400
C                    = 0 => STORED AS ANGLES IN DEGREES                 00004500
C                    = 1 => STORED AS LINEAR OBJECT SIZES               00004600
C                                                                       00004700
C             OFLAG  = SYSTEM UNITS FLAG                                00004800
C                    = 1 => MM                                          00004900
C                    = 2 => CM                                          00005000
C                    = 3 => INCHES                                      00005100
C                                                                       00005200
C  /PMATX/    UFLAG  - UNITS FLAG                                       00005300
C                    = 1 => MM                                          00005400
C                    = 2 => CM                                          00005500
C                    = 3 => INCHES                                      00005600
C                    = 4 => TANGENTS OF OUTPUT ANGLES WITH RESPECT      00005700
C                           TO OPTICAL AXIS                             00005800
C                    = 5 => ANGLES OF INCIDENCE WITH RESPECT TO NORMAL  00005900
C                           DEGREES.                                    00006000
C                                                                       00006100
C                                                                       00006200
C    /CSPOT/     IOPA - SPOT PLOT (UNITS) SWITCH                        00006300
C    /CRED/      IOPB - RADIAL ENERGY DIST PLOT SW                      00006400
C    /CMTF/      IOPC - MODULATION TRANSFER FUNCTION PLOT SW            00006500
C                                                                       00006600
C     OPTNA   OPTION A   PRINTS PRIME IMAGE COORD ONLY                  00006700
C     OPTNB   OPTION B   PRINTS COORD AND COSINES IN EP AND IMAGE       00006800
C     OPTNC   OPTION C   PRINTS COORD FOR SURFACES                      00006900
C     OPTND   OPTION D   CAUSES PRESCRIPTION MATRIX PRINT               00007000
C     OPTNE   OPTION E   PRINTS RED TABLES                              00007100
C     OPTNF   OPTION F   PRINTS MTF TABLES                              00007200
C     OPTNG   OPTION G   CAUSES ANALYSIS FOR EACH HEIGHT, COLOR         00007300
C                                                                       00007400
C                                                                       00007500
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00007600
C                                                                       00007700
C                     COMMONS                                           00007800
C                                                                       00007900
C                                                                       00008000
C   /PMATX/ -  most of these are set in MAIN as the                     00008100
C              result of input cards.                                   00008200
C                                                                       00008300
C             XSMIN       x(min) for spot diagrams    PLOT SCALE        00008400
C             XSMAX       x(max) for spot diagrams    PLOT SCALE        00008500
C             YSMIN       y(min) for spot diagrams    PLOT SCALE        00008600
C             YSMAX       y(max) for spot diagrams    PLOT SCALE        00008700
C                                                                       00008800
C?            FCODE       focusing code               FOCUS             00008900
C             FXYJ        historical variable                           00009000
C             FXY         =RHO, set in SKEW and PARAX                   00009100
C             FXNU        =RHO/(S-D);   "                               00009200
C             FBY         =0. always                                    00009300
C             FBNU        =-HYMAX/(S-D)                                 00009400
C                                                                       00009500
C             S           object - pupil distance     TH                00009600
C             D           location of 1st real        SAY               00009700
C                         surface with respect to                       00009800
C                         the entrance pupil                            00009900
C                                                                       00010000
C             RHO         radius of entrance pupil    SAY               00010100
C             UFLAG  -    Units flag                                    00010200
C                         = 1 => millimeters          UNITS MM          00010300
C                         = 2 => centimeters          UNITS CM          00010400
C                         = 3 => inches               UNITS INCHES      00010500
C                         = 4 => output angle tangent MODE AFOCAL       00010600
C                         = 5 => incident angles(rad) MODE ANGLES       00010700
C                                                                       00010800
C                                                                       00010900
C                                                                       00011000
C                                                                       00011100
C                                                                       00011200
C             RNOBJ       Number of object points     SCX or SCY        00011300
C             HYINIT      Initial Y-object height     SCY               00011400
C             HYDEL       Y-object height increment   SCY               00011500
C             HXINIT      Initial X object height     SCX               00011600
C             HXDEL       X-object height increment   SCX               00011700
C                 Related IFLAG = 0 => H?INIT, H?DEL                    00011800
C                                      stored as ang-                   00011900
C                                      les in degrees                   00012000
C                               = 1 => linear measure                   00012100
C                                      (system units)                   00012200
C                                                                       00012300
C             APSTOP      System aperture stop        ASTOP             00012400
C                         surface number                                00012500
C             SMAX        MTF maximum spatial         PLOT GOTF or      00012600
C                         frequency.                  PRINT GOTF        00012700
C             RSMAX       RED maximum radius          PLOT RED or       00012800
C                                                     PRINT RED         00012900
C             FOCL        System focal length         CFL               00013000
C             OBJN(3)     Indices of refraction of    GLASS or          00013100
C                         object medium (3 colors)    AIR               00013200
C             DELIMP      separation between image    IMAGE SEP         00013300
C                         surfaces                                      00013400
C             FPLANE      position of first image     IMAGE FIRST       00013500
C                         plane w.r.t. prime plane                      00013600
C             FAKEA       Surface number for STAT     STAT              00013700
C                         output.                                       00013800
C                     REL ATED:  IPR20 = 0 => dev. 6                    00013900
C                                      = 1 => dev.20                    00014000
C                                                                       00014100
C             C(40)       Vertex curvature            CV                00014200
C             T(40)       V-V' thickness              TH                00014300
C             R(40)       Vertex radius of curvature  RD                00014400
C             CONIC(40)   Conic Constant              CC                00014500
C             FN(40,3)    Indices of refraction       GLASS or          00014600
C                                                     AIR               00014700
C                                                                       00014800
C             FMASK(40)   = 1 => clear aperture       CLAP              00014900
C                         = -1 => obscuration         COBS              00015000
C                         = R > 0 => clear circular   CLAP              00015100
C                         = -R <0 => circular obscur  COBS              00015200
C             FAKEC(40)   = 0 => circular             CLAP or COBS      00015300
C                         = 1 => rectangular mask     CLAP RECT or      00015400
C                                                     COBS RECT         00015500
C                         =-1 => Elliptical Mask      CLAP ELIP or      00015600
C                                                     COBS ELIP         00015700
C                                                                       00015800
C                                                                       00015900
C?            FAKEB(40)                                                 00016000
C             XMN(40)     center of circle OR         CLAP,             00016100
C                         left most X                 CLAP RECT         00016200
C                         center of ellipse           CLAP ELIP         00016300
C             XMX(40)     not used                    CLAP,             00016400
C                         right most X                CLAP RECT         00016500
C                         x-radius                    CLAP ELIP         00016600
C             YMN(40)     same as XMN but for Y                         00016700
C             YMX(40)     same as XMX but for Y                         00016800
C                                                                       00016900
C                                                                       00017000
C             XDISP(40)   X decenter                  DEC               00017100
C             YDISP(40)   Y decenter                  DEC               00017200
C                                                                       00017300
C             TILTX(40)   X tilt                      TILT              00017400
C             TILTY(40)   Y tilt                      TILT              00017500
C             TILTZ(40)   Z tilt                      TILT              00017600
C                                                                       00017700
C             ORDN(40,3)  grating orders (3 colors)   GORD              00017800
C             SIDE(40)    direction of incidence for  CONV              00017900
C                         ray                         CONC              00018000
C             RDSPAC(40)  grid spacings               GRATX             00018100
C                                                     GRATY             00018200
C                                                                       00018300
C                                                                       00018400
C?            Y0(40)                                                    00018500
C             SXY(40)     height of axial ray in      PY                00018600
C                         thickness solve                               00018700
C             SXNU(40)    angle of axial ray in       PIY               00018800
C                         curvature solve                               00018900
C             COEF(40, 4) higher order surface        ASPH              00019000
C                         coefficients                                  00019100
C             RX(40)      toric radius of curvature   RDX               00019200
C             CX(40)      toric curvature             CVX               00019300
C             FREF(40)    Flag for REFlection                           00019400
C                         = 1 => transmissive         GLASS or AIR      00019500
C                         = -1 => reflective          REFL              00019600
C             FREF0       same as FREF but for object                   00019700
C                                                                       00019800
C             WAVL(3)     Wavelengths                 WV                00019900
C                                                                       00020000
C *********** *************************************** *******           00020100
C                                                                       00020200
C   /COLLAT/                                                            00020300
C                                                                       00020400
C             CLTRA(300)  Lattice points                                00020500
C             RADIMG      Image surf. radius of curv- IMAGE RD          00020600
C                         ature                                         00020700
C             CVIMG       Image surf. curvature       IMAGE CV          00020800
C             CONIMG      Image surf. conic constant  IMAGE CC          00020900
C             NPLANE      Number of image surfs.      IMAGE SURF        00021000
C             LATYPE      Lattice type flag                             00021100
C                         = 1 => single ray           SPD RAY           00021200
C                         = 2 => polar lattice        SPD POL           00021300
C                         = 3 => rectangular lattice  SPD RECT          00021400
C                         = 4 => FINRAY lattice                         00021500
C                         = 5 => one point                              00021600
C                         = 6 => read lattice from    SPD OPFILE or     00021700
C                                                     SPD FILE          00021800
C                         = 7 => Rim lattice          SPD RIM           00021900
C             ICOL(3)     color numbers               SPD               00022000
C             NCOL        number colors                                 00022100
C             NSURF       number surfaces                               00022200
C             IMODE       mode flag                                     00022300
C             IPRINT      print flag                                    00022400
C             IPLTPR      plot flag                                     00022500
C             IWVFLG(3)   wavelength set flag                           00022600
C             IPR20       dev. 20 print flag                            00022700
C             IREF        reference surface number                      00022800
C             IJK         historical vbl. always 0                      00022900
C             IALLPL      = 1 => multiple spot plot                     00023000
C                         = 0 => single spot plot                       00023100
CCCCCCCCCCCCC                                                           00023200
C                                                                       00023300
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00023400
C                                                                       00023500
C     LAST UPDATE 4/27/84 BY JOHN PARKER OF SSAI                        00023600
C                                                                       00023700
C 4/19/84        PUT STATEMENT 'IFLAG = 0' IN MAIN JUST BEFORE LINE     00023800
C                LABELED 1732                                           00023900
C                FORMATS CORRECTED; COMMAS PUT BETWEEN BLOCKS IN ACCORD 00024000
C                WITH ANS STANDARD.                                     00024100
C                                                                       00024200
C 4/11/84        UPDATE--      SKEW LOGIC LEADING TO RED FIXED.         00024300
C                                                                       00024400
C 4/10/84        UPDATE-- SUBROUTINE PARAX ERROR IN ABERRATIONS CALC-   00024500
C                         LATION BROUGHT IN LINE WITH USER'S MANUAL.    00024600
C                                                                       00024700
C 4/09/84        ABBERATION COEFS. DEFINITION TABLE NOW IN PARAX.       00024800
C                                                                       00024900
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00025000
C                                                                       00025100
C     MAIN   - CARD INPUT AND DECODING ROUTINE (APPROX. 1675 LINES)     00025200
C                                                                       00025300
      IMPLICIT REAL *8 (A-H,O-Z)                                        00025400
      INTEGER*4 ALPHA,ARRAY1                                            00025500
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00025600
C                                                                       00025700
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00025800
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00025900
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00026000
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00026100
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00026200
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00026300
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00026400
     $                FREF(40),FREF0,WAVL(3)                            00026500
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00026600
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00026700
     $                IPR20,IREF,IJK,IALLPL                             00026800
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00026900
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00027000
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00027100
C                                                                       00027200
C                                                                       00027300
      DIMENSION INPUT(80),IWORD1(40),IWORD2(40),ARRAY1(80),ARRAY(20)    00027400
      DIMENSION ALPHA(26),NUM(10),INPUT2(80),WAVE(3),DEFWV(3)           00027500
C                                                                       00027600
      DATA ALPHA /'A','B','C','D','E','F','G','H','I','J','K','L','M',  00027700
     $            'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/  00027800
      DATA NUM   /'1','2','3','4','5','6','7','8','9','0'/              00027900
      DATA IZERO/0/,IONE/1/,ITWO/2/,ITHREE/3/,IFOUR/4/,I81/81/          00028000
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/,       00028100
     $     FIVE/5.D0/                                                   00028200
      DATA IBLANK/1H /,ISLASH/'/'/,IVAL/1H,/                            00028300
      DATA PI/3.1415926535897932384626433832795D0/                      00028400
C                                                                       00028500
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00028600
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00028700
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00028800
      EQUIVALENCE (TRASH(10),FBNU)                                      00028900
C                                                                       00029000
   10 FORMAT (T1,80A1)                                                  00029100
   20 FORMAT (10X,80A1)                                                 00029200
   30 FORMAT (T2,'END OF PROGRAM'/)                                     00029300
   40 FORMAT (//)                                                       00029400
   50 FORMAT (15X,'FIRST WORD MUST START IN COLUMNS 1 THROUGH 6')       00029500
   60 FORMAT (15X,'NO BLANK OR COMMA FOLLOWING WORD 1'/)                00029600
   70 FORMAT (15X,'NO BLANK OR COMMA FOLLOWING WORD 2'/)                00029700
   80 FORMAT (15X,'UNIDENTIFIED CARD, = ',80A1/)                        00029800
   84 FORMAT (15X,'SURFACE NOT SPECIFIED FOR "GRATD" CARD '/)           00029900
   85 FORMAT (15X,'SURFACE NOT SPECIFED FOR "CLAPD" OR "COBSD" CARDS'/) 00030000
   86 FORMAT (15X,'SURFACE NOT SPECIFIED FOR "ASPHD" CARD '/)           00030100
   90 FORMAT (15X,'CANNOT IDENTIFY COLORS'/)                            00030200
   95 FORMAT (15X,'CALLED "SPD GEN" BEFORE CALLING "LATT GEN"'/)        00030300
  100 FORMAT (15X,'UNIDENTIFIED WORD 2 ON "SCY" CARD',20A1/)            00030400
  110 FORMAT (15X,'UNIDENTIFIED WORD2 ON "UNITS" CARD',20A1/)           00030500
  112 FORMAT (15X,'UNIDENTIFIED WORD2 ON "MODE" CARD',20A1/)            00030600
  120 FORMAT (15X,'TRYING TO FOCUS BEFORE "SPD" HAS BEEN CALLED'/)      00030700
  124 FORMAT (15X,'UNIDENTIFIED TYPE OF PLOT: ',20A1/)                  00030800
  126 FORMAT (15X,'UNIDENTIFIED TYPE OF PRINTOUT: ',20A1/)              00030900
  130 FORMAT (15X,'CALLED TEL- DESIGN ROUTINES BEFORE CALLING "PXTY"'/) 00031000
  140 FORMAT (15X,'UNKNOWN TYPE OF TEL-DESIGN ROUTINE: ',20A1/)         00031100
  150 FORMAT (15X,'UNKNOWN RAY LATTICE TYPE: ',20A1/)                   00031200
  160 FORMAT (15X,'UNKNOWN TYPE OF RAY FAN: ',20A1/)                    00031300
  165 FORMAT (15X,'LENS CARD NOT FIRST INPUT LINE'/)                    00031400
  166 FORMAT (15X,'UNIDENTIFIED "ASTOP" QUALIFIER: ',20A1/)             00031500
C                                                                       00031600
      REWIND 34                                                         00031700
      CALL GRAPH(1,0)                                                   00031800
C                                                                       00031900
      NSYS=IONE                                                         00032000
      ICASE=IZERO                                                       00032100
      ICARD=IZERO                                                       00032200
C             LOOP FOR READING INPUT DATA CARDS AND DETERMINING         00032300
C             WHAT TO DO WITH THEM                                      00032400
  170 DO 171 I=1,80                                                     00032500
      INPUT(I)=IBLANK                                                   00032600
  171 CONTINUE                                                          00032700
      READ (5,10,END=430) INPUT                                         00032800
      WRITE (6,20) INPUT                                                00032900
      ICARD = ICARD + IONE                                              00033000
      LAST=80                                                           00033100
  172 LET1=IZERO                                                        00033200
      DO 180 I=1,6                                                      00033300
        IF (INPUT(I).EQ.IBLANK) GO TO 180                               00033400
      LET1=I                                                            00033500
      GOTO 183                                                          00033600
  180 CONTINUE                                                          00033700
C             FIRST LETTER NOT FOUND                                    00033800
      IF (LET1.EQ.IZERO) WRITE(6,50)                                    00033900
C             FIND LOGICAL CARRIAGE RETURN, IF ANY                      00034000
  183 LSL=I81                                                           00034100
      DO 185 I=LET1,LAST                                                00034200
      IF (INPUT(I).NE.ISLASH) GO TO 185                                 00034300
      LSL=I                                                             00034400
      GOTO 186                                                          00034500
  185 CONTINUE                                                          00034600
  186 IF (LSL.EQ.IONE) GO TO 170                                        00034700
      LSLM1=LSL-IONE                                                    00034800
      DO 188 I=LET1,LSLM1                                               00034900
      INPUT2(I)=INPUT(I)                                                00035000
  188 CONTINUE                                                          00035100
C             SEE IF INPUT IS A COMMENT STATEMENT                       00035200
      IF (INPUT(LET1).EQ.ALPHA(3).AND.INPUT(LET1+1).EQ.IVAL) GO TO 170  00035300
      IF (INPUT(LET1).EQ.ALPHA(3).AND.INPUT(LET1+1).EQ.IBLANK           00035400
     $     .AND.INPUT(LET1+2).EQ.IBLANK) GO TO 170                      00035500
      IF (LSL.EQ.I81) GO TO 191                                         00035600
      DO 190 I=LSL,80                                                   00035700
      INPUT2(I)=IBLANK                                                  00035800
  190 CONTINUE                                                          00035900
C             NEED TO INITIALIZE FIRST                                  00036000
  191 CONTINUE                                                          00036100
      DO 200 I=1,40                                                     00036200
        IWORD1(I)=IBLANK                                                00036300
        IWORD2(I)=IBLANK                                                00036400
  200 CONTINUE                                                          00036500
      DO 210 I=1,20                                                     00036600
        ARRAY(I)=ZERO                                                   00036700
  210 CONTINUE                                                          00036800
      DO 220 I=1,80                                                     00036900
        ARRAY1(I)=IBLANK                                                00037000
  220 CONTINUE                                                          00037100
C             FIND FIRST BLANK OR COMMA,                                00037200
C             STORE POSITION AS "L1"                                    00037300
      L1=IZERO                                                          00037400
      DO 230 I=LET1,LAST                                                00037500
        IF ((INPUT2(I).NE.IBLANK).AND.(INPUT2(I).NE.IVAL)) GO TO 230    00037600
        L1=I                                                            00037700
        GO TO 240                                                       00037800
  230 CONTINUE                                                          00037900
C             TEST TO SEE IF A BLANK OR COMMA IS FOUND;                 00038000
C             IF NOT, ERROR EXISTS                                      00038100
  240 IF (L1.NE.IZERO) GO TO 250                                        00038200
C             L1 = 0                                                    00038300
      WRITE (6,60)                                                      00038400
      GO TO 2083                                                        00038500
C             L1A = END OF WORD 1                                       00038600
C             L1B = BEGINNING OF WORD 2 OR NUMERIC FIELD                00038700
  250 L1A=L1-IONE                                                       00038800
      L1B=L1+IONE                                                       00038900
C             FIND SECOND BLANK, STORE POSITION AS "L2"                 00039000
      L2=IZERO                                                          00039100
      IF (INPUT2(L1).NE.IVAL) GO TO 255                                 00039200
      L2=L1B                                                            00039300
      GO TO 280                                                         00039400
  255 DO 260 I=L1B,LAST                                                 00039500
        IF ((INPUT2(I).NE.IBLANK).AND.(INPUT2(I).NE.IVAL)) GO TO 260    00039600
        L2=I                                                            00039700
        GO TO 270                                                       00039800
  260 CONTINUE                                                          00039900
C             FOUND SECOND BLANK, TEST TO SEE IF VALID                  00040000
  270 IF (L2.NE.IZERO) GO TO 280                                        00040100
C             L2 = 0                                                    00040200
      WRITE (6,70)                                                      00040300
      GO TO 2083                                                        00040400
C             L2A = END OF WORD 2                                       00040500
C             L2B = BEGINNING OF NUMERIC FIELD                          00040600
  280 L2A=L2-IONE                                                       00040700
      L2B=L2+IONE                                                       00040800
C             DETERMINE WORD1, FOUND IN COLS. LET1 - L1A                00040900
  285 M=IZERO                                                           00041000
      DO 290 I=LET1,L1A                                                 00041100
        M=M+IONE                                                        00041200
        IWORD1(M)=INPUT2(I)                                             00041300
  290 CONTINUE                                                          00041400
C             IF 2 BLANKS IN A ROW, NUMERIC FIELD STARTS AFTER 2ND ONE  00041500
C             BLANKS, IF FOUND, ARE IN COLS. L1 AND L1B                 00041600
      IF (L2.EQ.L1B) GO TO 301                                          00041700
C             WE HAVE A NON-BLANK WORD 2, GET IT                        00041800
      J=IZERO                                                           00041900
      DO 300 I=L1B,L2A                                                  00042000
        J=J+IONE                                                        00042100
        IWORD2(J)=INPUT2(I)                                             00042200
  300 CONTINUE                                                          00042300
C             FIND END OF NUMERIC FIELD                                 00042400
  301 L3=LAST                                                           00042500
      K=L2B                                                             00042600
      IF (INPUT2(L1).EQ.IVAL) K=L2                                      00042700
      DO 304 I=K,LAST                                                   00042800
      IF (INPUT2(I).NE.IBLANK) GOTO 303                                 00042900
      IF (L3.EQ.LAST) L3=I                                              00043000
      GO TO 304                                                         00043100
  303 L3=LAST                                                           00043200
  304 CONTINUE                                                          00043300
C             STORE NUMERIC FIELD IN "ARRAY1"                           00043400
  310 IF (L2.EQ.L1B) L2B=L1B+IONE                                       00043500
      J=IZERO                                                           00043600
      K=L2B                                                             00043700
      IF (INPUT2(L1).EQ.IVAL) K=L2                                      00043800
C         KBEG STORES FIRST NON BLANK CHARACTER IN NUMERIC FIELD        00043900
      KBEG=K                                                            00044000
      DO 315 I=K,LAST                                                   00044100
        IF (INPUT2(I).EQ.IBLANK) GO TO 315                              00044200
        KBEG=I                                                          00044300
        GO TO 316                                                       00044400
  315 CONTINUE                                                          00044500
  316 J=0                                                               00044600
      LENGTH=L3-KBEG                                                    00044700
      DO 320 I=KBEG,L3                                                  00044800
        J=J+IONE                                                        00044900
        ARRAY1(J)=INPUT2(I)                                             00045000
  320 CONTINUE                                                          00045100
C             COMPUTE LENGTH OF WORD 2                                  00045200
      LEN2=L2A-L1B+IONE                                                 00045300
      IF (LEN2.EQ.IZERO) LEN2=IONE                                      00045400
C                                                                       00045500
C                                                                       00045600
C             CONVERT NUMERIC FIELDS TO ACTUAL NUMBERS,                 00045700
C             IF CARD IS NOT AN "LI" CARD                               00045800
      IF ( IWORD1(1).EQ.ALPHA(12) .AND. IWORD1(2).EQ.ALPHA(9))          00045900
     $     GO TO 330                                                    00046000
C    5/21/84                                                            00046100
C     FORCE FLOTIN TO BE CALLED WITH LENGTH > 0                         00046110
      LENG = LENGTH                                                     00046120
      IF(LENG .LT. 1) LENG = 20                                         00046130
      CALL FLOTIN (0,ARRAY1,ARRAY,LENG)                                 00046200
C                                                                       00046300
C             AT THIS POINT, HAVE WORD1, WORD2, AND NUMERIC VALUES      00046400
C             USE ALPHA ARRAY TO DISTINGUISH COMMANDS                   00046500
C                                                                       00046600
C             THE 'LENS' CARD MUST BE FIRST LINE OF INPUT               00046700
C                                                                       00046800
C             GO TO 340 IF 'LENS' CARD                                  00046900
C                                                                       00047000
  330 IF ((IWORD1(1).NE.ALPHA(12) .OR. IWORD1(2).NE.ALPHA(5)            00047100
     $   .OR. IWORD1(3).NE.ALPHA(14) .OR. IWORD1(4).NE.ALPHA(19))       00047200
     $   .AND. ICARD.EQ.IONE) GO TO 333                                 00047300
C                                                                       00047400
      IF ( IWORD1(1).EQ.ALPHA(12) .AND. IWORD1(2).EQ.ALPHA(5)           00047500
     $   .AND. IWORD1(3).EQ.ALPHA(14).AND.IWORD1(4).EQ.ALPHA(19))       00047600
     $   GO TO 340                                                      00047700
      GO TO 337                                                         00047800
C             LENS NOT FIRST CARD, STOP                                 00047900
C                                                                       00048000
  333 WRITE(6,165)                                                      00048100
      GO TO 430                                                         00048200
C                                                                       00048300
C             GO TO 430 IF 'EXIT' CARD                                  00048400
C                                                                       00048500
  337 IF ( IWORD1(1).EQ.ALPHA(5) .AND. IWORD1(2).EQ.ALPHA(24)           00048600
     $     .AND. IWORD1(3).EQ.ALPHA(9).AND.IWORD1(4).EQ.ALPHA(20))      00048700
     $     GO TO 430                                                    00048800
C                                                                       00048900
C             GO TO 440 IF 'RD' OR 'CV' CARD                            00049000
C                                                                       00049100
      IF (IWORD1(1).EQ.ALPHA(18) .AND. IWORD1(2).EQ.ALPHA(4)) GO TO 440 00049200
      IF (IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(22)) GO TO 440 00049300
C                                                                       00049400
C             GO TO 580 IF 'TH' CARD                                    00049500
C                                                                       00049600
      IF (IWORD1(1).EQ.ALPHA(20) .AND. IWORD1(2).EQ.ALPHA(8)) GO TO 580 00049700
C                                                                       00049800
C             GO TO 590 IF 'GLASS' OR 'REFL' OR 'AIR' CARD              00049900
C                                                                       00050000
      IF ( IWORD1(1).EQ.ALPHA(1) .AND. IWORD1(2).EQ.ALPHA(9)            00050100
     $     .AND. IWORD1(3).EQ.ALPHA(18))  GO TO 590                     00050200
      IF ( IWORD1(1).EQ.ALPHA(18) .AND. IWORD1(2).EQ.ALPHA(5)           00050300
     $     .AND. IWORD1(3).EQ.ALPHA(6).AND.IWORD1(4).EQ.ALPHA(12))      00050400
     $     GO TO 590                                                    00050500
      IF ( IWORD1(1).EQ.ALPHA(7) .AND. IWORD1(2).EQ.ALPHA(12)           00050600
     $     .AND. IWORD1(3).EQ.ALPHA(1).AND.IWORD1(4).EQ.ALPHA(19)       00050700
     $     .AND.IWORD1(5).EQ.ALPHA(19)) GO TO 590                       00050800
C                                                                       00050900
C             GO TO 640 IF 'ASPH' CARD                                  00051000
C                                                                       00051100
      IF ( IWORD1(1).EQ.ALPHA(1) .AND. IWORD1(2).EQ.ALPHA(19)           00051200
     $     .AND. IWORD1(3).EQ.ALPHA(16).AND.IWORD1(4).EQ.ALPHA(8))      00051300
     $     GO TO 640                                                    00051400
C                                                                       00051500
C             GO TO 720 IF 'CC' CARD                                    00051600
C                                                                       00051700
      IF (IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(3)) GO TO 720  00051800
C                                                                       00051900
C             GO TO 723 IF 'CONC' CARD                                  00052000
C                                                                       00052100
      IF ( IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(15) .AND.     00052200
     $     IWORD1(3).EQ.ALPHA(14) .AND. IWORD1(4).EQ.ALPHA(3) )         00052300
     $     GO TO 723                                                    00052400
C                                                                       00052500
C             GO TO 726 IF 'CONV' CARD                                  00052600
      IF ( IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(15) .AND.     00052700
     $     IWORD1(3).EQ.ALPHA(14) .AND. IWORD1(4).EQ.ALPHA(22) )        00052800
     $     GO TO 726                                                    00052900
C                                                                       00053000
C             GO TO 730 IF OR 'DEC' CARD                                00053100
C                                                                       00053200
      IF ( IWORD1(1).EQ.ALPHA(4) .AND. IWORD1(2).EQ.ALPHA(5)            00053300
     $     .AND. IWORD1(3).EQ.ALPHA(3)) GO TO 730                       00053400
C                                                                       00053500
C             GO TO 760 IF 'TILT' CARD                                  00053600
C                                                                       00053700
      IF ( IWORD1(1).EQ.ALPHA(20) .AND. IWORD1(2).EQ.ALPHA(9)           00053800
     $     .AND. IWORD1(3).EQ.ALPHA(12).AND.IWORD1(4).EQ.ALPHA(20))     00053900
     $     GO TO 760                                                    00054000
C                                                                       00054100
C             GO TO 810 IF 'RTILT' CARD                                 00054200
C                                                                       00054300
      IF ( IWORD1(1).EQ.ALPHA(18) .AND. IWORD1(2).EQ.ALPHA(20)          00054400
     $     .AND. IWORD1(3).EQ.ALPHA(9).AND.IWORD1(4).EQ.ALPHA(12)       00054500
     $     .AND.IWORD1(5).EQ.ALPHA(20)) GO TO 810                       00054600
C                                                                       00054700
C             GO TO 850 IF 'GRAT' CARD OR 'GRATD' CARD                  00054800
C                                                                       00054900
      IF ( IWORD1(1).EQ.ALPHA(7) .AND. IWORD1(2).EQ.ALPHA(18)           00055000
     $     .AND. IWORD1(3).EQ.ALPHA(1).AND.IWORD1(4).EQ.ALPHA(20))      00055100
     $     GO TO 850                                                    00055200
C                                                                       00055300
C             GO TO 860 IF "GORD" CARD                                  00055400
C                                                                       00055500
      IF (IWORD1(1).EQ.ALPHA(7).AND.IWORD1(2).EQ.ALPHA(15)              00055600
     $     .AND.IWORD1(3).EQ.ALPHA(18).AND.IWORD1(4).EQ.ALPHA(4))       00055700
     $     GO TO 860                                                    00055800
C                                                                       00055900
C             GO TO 910 IF 'CLAP' OR 'CLAPD' CARD                       00056000
C                                                                       00056100
      IF ( IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(12)           00056200
     $     .AND. IWORD1(3).EQ.ALPHA(1).AND.IWORD1(4).EQ.ALPHA(16))      00056300
     $     GO TO 910                                                    00056400
C                                                                       00056500
C             GO TO 950 IF 'COBS' CARD                                  00056600
C                                                                       00056700
      IF ( IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(15)           00056800
     $     .AND. IWORD1(3).EQ.ALPHA(2).AND.IWORD1(4).EQ.ALPHA(19))      00056900
     $     GO TO 950                                                    00057000
C                                                                       00057100
C             GO TO 1060 IF 'PXTY' CARD                                 00057200
C                                                                       00057300
      IF ( IWORD1(1).EQ.ALPHA(16) .AND. IWORD1(2).EQ.ALPHA(24)          00057400
     $     .AND. IWORD1(3).EQ.ALPHA(20).AND.IWORD1(4).EQ.ALPHA(25))     00057500
     $     GO TO 1060                                                   00057600
C                                                                       00057700
C             GO TO 1110 IF 'SCY' OR 'SCX' CARD                         00057800
C                                                                       00057900
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(3)           00058000
     $     .AND.(IWORD1(3).EQ.ALPHA(24).OR.IWORD1(3).EQ.ALPHA(25)))     00058100
     $     GO TO 1110                                                   00058200
C                                                                       00058300
C             GO TO 1240 IF 'IMAGE' CARD                                00058400
C                                                                       00058500
      IF ( IWORD1(1).EQ.ALPHA(9) .AND. IWORD1(2).EQ.ALPHA(13)           00058600
     $     .AND. IWORD1(3).EQ.ALPHA(1).AND.IWORD1(4).EQ.ALPHA(7)        00058700
     $     .AND.IWORD1(5).EQ.ALPHA(5)) GO TO 1240                       00058800
C                                                                       00058900
C             GO TO 1340 IF 'UNITS' CARD                                00059000
C                                                                       00059100
      IF ( IWORD1(1).EQ.ALPHA(21) .AND. IWORD1(2).EQ.ALPHA(14)          00059200
     $     .AND. IWORD1(3).EQ.ALPHA(9).AND.IWORD1(4).EQ.ALPHA(20)       00059300
     $     .AND.IWORD1(5).EQ.ALPHA(19)) GO TO 1340                      00059400
C                                                                       00059500
C             GO TO 1375 IF "MODE" CARD                                 00059600
C                                                                       00059700
      IF (IWORD1(1).EQ.ALPHA(13).AND.IWORD1(2).EQ.ALPHA(15)             00059800
     $     .AND.IWORD1(3).EQ.ALPHA(4).AND.IWORD1(4).EQ.ALPHA(5))        00059900
     $     GO TO 1375                                                   00060000
C                                                                       00060100
C             GO TO 1400 IF 'FOCUS' CARD                                00060200
C                                                                       00060300
      IF ( IWORD1(1).EQ.ALPHA(6) .AND. IWORD1(2).EQ.ALPHA(15)           00060400
     $     .AND. IWORD1(3).EQ.ALPHA(3)) GO TO 1400                      00060500
C                                                                       00060600
C             GO TO 1420 IF 'CFL' CARD                                  00060700
C                                                                       00060800
      IF (IWORD1(1).EQ.ALPHA(3) .AND. IWORD1(2).EQ.ALPHA(6)             00060900
     $     .AND.IWORD1(3).EQ.ALPHA(12)) GO TO 1420                      00061000
C                                                                       00061100
C             GO TO 1430 IF 'SAG' CARD                                  00061200
C                                                                       00061300
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(1)           00061400
     $     .AND. IWORD1(3).EQ.ALPHA(7)) GO TO 1430                      00061500
C                                                                       00061600
C             GO TO 1440 IF 'LI' CARD                                   00061700
C                                                                       00061800
      IF ( IWORD1(1).EQ.ALPHA(12).AND.IWORD1(2).EQ.ALPHA(9))            00061900
     $     GO TO 1440                                                   00062000
C                                                                       00062100
C             GO TO 1490 IF 'PLOT' CARD                                 00062200
C                                                                       00062300
      IF ( IWORD1(1).EQ.ALPHA(16) .AND. IWORD1(2).EQ.ALPHA(12)          00062400
     $     .AND. IWORD1(3).EQ.ALPHA(15).AND.IWORD1(4).EQ.ALPHA(20))     00062500
     $     GO TO 1490                                                   00062600
C                                                                       00062700
C             GO TO 1492 IF "NOPLOT' CARD                               00062800
C                                                                       00062900
      IF (IWORD1(1).EQ.ALPHA(14).AND.IWORD1(2).EQ.ALPHA(15)             00063000
     $     .AND.IWORD1(3).EQ.ALPHA(16).AND.IWORD1(4).EQ.ALPHA(12)       00063100
     $     .AND.IWORD1(5).EQ.ALPHA(15).AND.IWORD1(6).EQ.ALPHA(20))      00063200
     $     GO TO 1492                                                   00063300
C                                                                       00063400
C             GO TO 1494 IF "PRINT" CARD                                00063500
C                                                                       00063600
      IF (IWORD1(1).EQ.ALPHA(16).AND.IWORD1(2).EQ.ALPHA(18)             00063700
     $     .AND.IWORD1(3).EQ.ALPHA(9).AND.IWORD1(4).EQ.ALPHA(14)        00063800
     $     .AND.IWORD1(5).EQ.ALPHA(20)) GO TO 1494                      00063900
C                                                                       00064000
C             GO TO 1496 IF "NOPRNT" CARD                               00064100
C                                                                       00064200
      IF (IWORD1(1).EQ.ALPHA(14).AND.IWORD1(2).EQ.ALPHA(15)             00064300
     $     .AND.IWORD1(3).EQ.ALPHA(16).AND.IWORD1(4).EQ.ALPHA(18)       00064400
     $     .AND.IWORD1(5).EQ.ALPHA(14).AND.IWORD1(6).EQ.ALPHA(20))      00064500
     $     GO TO 1496                                                   00064600
C                                                                       00064700
C             GO TO 1500 IF 'SAY' CARD                                  00064800
C                                                                       00064900
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(1)           00065000
     $     .AND. IWORD1(3).EQ.ALPHA(25)) GO TO 1500                     00065100
C                                                                       00065200
C             GO TO 1510 IF 'DES' CARD                                  00065300
C                                                                       00065400
      IF ( IWORD1(1).EQ.ALPHA(4) .AND. IWORD1(2).EQ.ALPHA(5)            00065500
     $     .AND. IWORD1(3).EQ.ALPHA(19)) GO TO 1510                     00065600
C                                                                       00065700
C             GO TO 1560 IF 'ASTOP' CARD                                00065800
C                                                                       00065900
      IF ( IWORD1(1).EQ.ALPHA(1) .AND. IWORD1(2).EQ.ALPHA(19)           00066000
     $     .AND. IWORD1(3).EQ.ALPHA(20).AND.IWORD1(4).EQ.ALPHA(15)      00066100
     $     .AND. IWORD1(5).EQ.ALPHA(16)) GOTO 1560                      00066200
C                                                                       00066300
C             GO TO 1566 IF 'LATT' CARD                                 00066400
C                                                                       00066500
      IF (IWORD1(1).EQ.ALPHA(12).AND.IWORD1(2).EQ.ALPHA(1)              00066600
     $     .AND.IWORD1(3).EQ.ALPHA(20).AND.IWORD1(4).EQ.ALPHA(20))      00066700
     $     GO TO 1566                                                   00066800
C                                                                       00066900
C             GO TO 1570 IF 'SPD' CARD                                  00067000
C                                                                       00067100
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(16)          00067200
     $     .AND. IWORD1(3).EQ.ALPHA(4)) GO TO 1570                      00067300
C                                                                       00067400
C             GO TO 1830 IF 'BIL' CARD                                  00067500
C                                                                       00067600
      IF ( IWORD1(1).EQ.ALPHA(2) .AND. IWORD1(2).EQ.ALPHA(9)            00067700
     $     .AND. IWORD1(3).EQ.ALPHA(12)) GO TO 1830                     00067800
C                                                                       00067900
C             GO TO 1880 IF 'LEPRT' CARD                                00068000
C                                                                       00068100
      IF (IWORD1(1).EQ.ALPHA(12).AND.IWORD1(2).EQ.ALPHA(5)              00068200
     $     .AND.IWORD1(3).EQ.ALPHA(16).AND.IWORD1(4).EQ.ALPHA(18)       00068300
     $     .AND.IWORD1(5).EQ.ALPHA(20)) GO TO 1880                      00068400
C                                                                       00068500
C             GO TO 1900 IF 'SC' CARD                                   00068600
C                                                                       00068700
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(3)           00068800
     $     .AND. IWORD1(3).EQ.IBLANK) GO TO 1900                        00068900
C                                                                       00069000
C             GO TO 1910 IF 'WV' CARD                                   00069100
C                                                                       00069200
      IF ( IWORD1(1).EQ.ALPHA(23) .AND. IWORD1(2).EQ.ALPHA(22)          00069300
     $     .AND. IWORD1(3).EQ.IBLANK) GO TO 1910                        00069400
C                                                                       00069500
C             GO TO 1920 IF 'INSERT' CARD                               00069600
C                                                                       00069700
      IF ( IWORD1(1).EQ.ALPHA(9) .AND. IWORD1(2).EQ.ALPHA(14)           00069800
     $     .AND. IWORD1(3).EQ.ALPHA(19)) GO TO 1920                     00069900
C                                                                       00070000
C             GO TO 1930 IF 'DELETE' CARD                               00070100
C                                                                       00070200
      IF ( IWORD1(1).EQ.ALPHA(4) .AND. IWORD1(2).EQ.ALPHA(5)            00070300
     $     .AND. IWORD1(3).EQ.ALPHA(12)) GO TO 1930                     00070400
C                                                                       00070500
C             GO TO 1940 IF 'REFS' CARD                                 00070600
C                                                                       00070700
      IF ( IWORD1(1).EQ.ALPHA(18).AND.IWORD1(2).EQ.ALPHA(5)             00070800
     $     .AND.IWORD1(3).EQ.ALPHA(6).AND.IWORD1(4).EQ.ALPHA(19))       00070900
     $     GO TO 1940                                                   00071000
C                                                                       00071100
C             GO TO 1970 IF 'STAT' CARD                                 00071200
C                                                                       00071300
      IF ( IWORD1(1).EQ.ALPHA(19) .AND. IWORD1(2).EQ.ALPHA(20)          00071400
     $     .AND. IWORD1(3).EQ.ALPHA(1)) GO TO 1970                      00071500
C                                                                       00071600
C             TEST FOR "PY", "PIY", OR "CAY" CARD                       00071700
C                                                                       00071800
      IF ( IWORD1(1).EQ.ALPHA(16) .AND. IWORD1(2).EQ.ALPHA(25))         00071900
     $     GO TO 2010                                                   00072000
      IF (IWORD1(1).EQ.ALPHA(16).AND.IWORD1(2).EQ.ALPHA(9)              00072100
     $     .AND.IWORD1(3).EQ.ALPHA(25)) GO TO 1990                      00072200
      IF (IWORD1(1).EQ.ALPHA(3).AND.IWORD1(2).EQ.ALPHA(1)               00072300
     $     .AND.IWORD1(3).EQ.ALPHA(25)) GO TO 2000                      00072400
C                                                                       00072500
C             GO TO 2020 IF "SLVD" CARD                                 00072600
C                                                                       00072700
      IF (IWORD1(1).EQ.ALPHA(19).AND.IWORD1(2).EQ.ALPHA(12)             00072800
     $     .AND.IWORD1(3).EQ.ALPHA(22).AND.IWORD1(4).EQ.ALPHA(4))       00072900
     $     GO TO 2020                                                   00073000
C                                                                       00073100
C             AT THIS POINT, CARD IS UNIDENTIFIED; PRINT MESSAGE        00073200
  335 WRITE (6,80) INPUT2                                               00073300
      GO TO 2083                                                        00073400
C                                                                       00073500
C             HERE IF "LENS" CARD                                       00073600
C                             BEGIN INITIALIZATION                      00073700
C                                                                       00073800
  340 DO 350 I=1,10                                                     00073900
        TRASH(I)=ZERO                                                   00074000
  350 CONTINUE                                                          00074100
      S=ZERO                                                            00074200
      D=ZERO                                                            00074300
      RHO=ZERO                                                          00074400
      UFLAG=ZERO                                                        00074500
      OFLAG=ZERO                                                        00074600
      RNOBJ=ZERO                                                        00074700
      HYINIT=ZERO                                                       00074800
      HYDEL=ZERO                                                        00074900
      HXINIT=ZERO                                                       00075000
      HXDEL=ZERO                                                        00075100
      APSTOP=ZERO                                                       00075200
      SMAX=ZERO                                                         00075300
      RSMAX=ZERO                                                        00075400
      IREF=IZERO                                                        00075500
      FOCL=ZERO                                                         00075600
      DO 360 I=1,3                                                      00075700
        WAVL(I)=ZERO                                                    00075800
        OBJN(I)=ZERO                                                    00075900
        WAVE(I)=ZERO                                                    00076000
  360 CONTINUE                                                          00076100
      DELIMP=ZERO                                                       00076200
      FPLANE=ZERO                                                       00076300
      FAKEA=ZERO                                                        00076400
      DO 390 I=1,40                                                     00076500
        C(I)=ZERO                                                       00076600
        T(I)=ZERO                                                       00076700
        R(I)=ZERO                                                       00076800
        CONIC(I)=ZERO                                                   00076900
        DO 370 J=1,3                                                    00077000
          FN(I,J)=ZERO                                                  00077100
          ORDN(I,J)=ZERO                                                00077200
  370   CONTINUE                                                        00077300
        FMASK(I)=ZERO                                                   00077400
        FAKEC(I)=ZERO                                                   00077500
        FAKEB(I)=ZERO                                                   00077600
        XDISP(I)=ZERO                                                   00077700
        YDISP(I)=ZERO                                                   00077800
        TILTX(I)=ZERO                                                   00077900
        TILTY(I)=ZERO                                                   00078000
        TILTZ(I)=ZERO                                                   00078100
        SIDE(I)=ZERO                                                    00078200
        RDSPAC(I)=ZERO                                                  00078300
        Y0(I)=ZERO                                                      00078400
        SXY(I)=ZERO                                                     00078500
        SXNU(I)=ZERO                                                    00078600
        DO 380 J=1,4                                                    00078700
          COEF(I,J)=ZERO                                                00078800
  380   CONTINUE                                                        00078900
        XMN(I)=ZERO                                                     00079000
        XMX(I)=ZERO                                                     00079100
        YMN(I)=ZERO                                                     00079200
        YMX(I)=ZERO                                                     00079300
        RX(I)=ZERO                                                      00079400
        CX(I)=ZERO                                                      00079500
        FREF(I)=ZERO                                                    00079600
  390 CONTINUE                                                          00079700
C                                                                       00079800
      FREF0 = ZERO                                                      00079900
C                                                                       00080000
      ENPUPR=ZERO                                                       00080100
      ENPUPL=ZERO                                                       00080200
      EXPUPR=ZERO                                                       00080300
      EXPUPL=ZERO                                                       00080400
C                                                                       00080500
      ISRF   = IZERO                                                    00080600
      IFLAG  = IZERO                                                    00080700
      YMAX   = ZERO                                                     00080800
      YMIN   = ZERO                                                     00080900
      DELY   = ZERO                                                     00081000
      REFCRV = ZERO                                                     00081100
      CONST  = ZERO                                                     00081200
      WAVENM = ZERO                                                     00081300
C                                                                       00081400
      DO 400 I=1,300                                                    00081500
        CLTRA(I)=ZERO                                                   00081600
  400 CONTINUE                                                          00081700
      RADIMG=ZERO                                                       00081800
      CVIMG=ZERO                                                        00081900
      CONIMG=ZERO                                                       00082000
      NPLANE=IONE                                                       00082100
      LATYPE=IZERO                                                      00082200
      DO 410 I=1,3                                                      00082300
        ICOL(I)=IZERO                                                   00082400
  410 CONTINUE                                                          00082500
      NCOL=IZERO                                                        00082600
      NSURF=IZERO                                                       00082700
      IMODE=IZERO                                                       00082800
      IPRINT=IZERO                                                      00082900
      IPLTPR=IZERO                                                      00083000
C                                                                       00083100
      LINES=ITWO                                                        00083200
      IPAGE=IZERO                                                       00083300
      LAMDA=IZERO                                                       00083400
      DO 420 I=1,160                                                    00083500
        NAME(I)=IBLANK                                                  00083600
  420 CONTINUE                                                          00083700
C                                                                       00083800
      IF (ICASE.NE.IZERO) NSYS=NSYS+IONE                                00083900
      ICASE=IONE                                                        00084000
      NFOC=IZERO                                                        00084100
      LFOC=IZERO                                                        00084200
      IFOC=IZERO                                                        00084300
      ISKEW=IZERO                                                       00084400
      INDEX=IONE                                                        00084500
      IPEN=IZERO                                                        00084600
      ISSTRA=IZERO                                                      00084700
      IAP=IZERO                                                         00084800
      LATFLG=IZERO                                                      00084900
      IPR20=IZERO                                                       00085000
      IALLPL=IZERO                                                      00085100
C                                                                       00085200
C                                                                       00085300
C                                                                       00085400
C             ISURF REPRESENTS THE CURRENT SURFACE NUMBER               00085500
C             FINAL NUMBER OF SURFACES (NSURF) IS DETERMINED            00085600
C             BY USING THE 'IMAGE' CARD                                 00085700
C                                                                       00085800
      ISURF=IZERO                                                       00085900
C             END OF INITIALIZATION                                     00086000
C                                                                       00086100
      GO TO 2083                                                        00086200
C                                                                       00086300
C             HERE IF "EXIT" OR END-OF-FILE                             00086400
  430 WRITE (6,30)                                                      00086500
      REWIND 34                                                         00086600
      CALL GRAPH(3,0)                                                   00086700
      GO TO 2090                                                        00086800
C                                                                       00086900
C             HERE IF "RD" OR "CV" CARD                                 00087000
C             DETERMINE SURFACE NUMBER TO USE FOR THIS DATA CARD        00087100
  440 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00087200
      IF (JSURF.GT.IZERO) GO TO 450                                     00087300
      WRITE(6,445)                                                      00087400
  445 FORMAT(T6,' OBJECT CANNOT HAVE RADIUS OR CURVATURE SPECIFIED ')   00087500
      GO TO 2083                                                        00087600
C             DETERMINE IF TORIC (XZ) DATA OR MERIDIONAL (YZ) DATA      00087700
  450   IF ( IWORD1(3).EQ.ALPHA(24)) GO TO 460                          00087800
C                                                                       00087900
C             FOUND MERIDIONAL DATA                                     00088000
      IF (IWORD1(1).EQ.ALPHA(3)) C(JSURF)=ARRAY(1)                      00088100
      IF (IWORD1(1).EQ.ALPHA(18)) R(JSURF)=ARRAY(1)                     00088200
      IF (R(JSURF).NE.ZERO) C(JSURF)=ONE/R(JSURF)                       00088300
      IF (R(JSURF).EQ.ZERO.AND.C(JSURF).NE.ZERO) R(JSURF)=ONE/C(JSURF)  00088400
      GO TO 2083                                                        00088500
C             FOUND TORIC DATA                                          00088600
  460 IF (IWORD1(1).EQ.ALPHA(3)) CX(JSURF)=ARRAY(1)                     00088700
      IF (IWORD1(1).EQ.ALPHA(18)) RX(JSURF)=ARRAY(1)                    00088800
      IF (RX(JSURF).NE.ZERO) CX(JSURF)=ONE/RX(JSURF)                    00088900
      IF ( RX(JSURF).EQ.ZERO .AND. CX(JSURF).NE.ZERO )                  00089000
     $     RX(JSURF) = ONE/CX(JSURF)                                    00089100
      Y0(JSURF)=ONE                                                     00089200
      GO TO 2083                                                        00089300
C                                                                       00089400
C             HERE IF "TH" CARD                                         00089500
C                                                                       00089600
  580 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00089700
      IF (JSURF.EQ.IZERO) GO TO 585                                     00089800
      T(JSURF)=ARRAY(1)                                                 00089900
      GO TO 2083                                                        00090000
  585 S=ARRAY(1)                                                        00090100
      GO TO 2083                                                        00090200
C                                                                       00090300
C             HERE IF "GLASS","AIR", OR "REFL" CARD                     00090400
C                                                                       00090500
  590 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00090600
      IF (IWORD1(1).EQ.ALPHA(1).AND.IWORD1(2).EQ.ALPHA(9))  GO TO 600   00090700
      IF (IWORD1(1).EQ.ALPHA(18).AND.IWORD1(2).EQ.ALPHA(5)) GO TO 610   00090800
      IF (IWORD1(1).EQ.ALPHA(7).AND.IWORD1(2).EQ.ALPHA(12)) GO TO 620   00090900
      GO TO 2083                                                        00091000
C             FOUND 'AIR' CARD                                          00091100
  600 IF (JSURF.EQ.IZERO) GO TO 605                                     00091200
      FN(JSURF,1) = ONE                                                 00091300
      FN(JSURF,2) = ONE                                                 00091400
      FN(JSURF,3) = ONE                                                 00091500
      FREF(JSURF) = ONE                                                 00091600
      GO TO 630                                                         00091700
  605 OBJN(1) = ONE                                                     00091800
      OBJN(2) = ONE                                                     00091900
      OBJN(3) = ONE                                                     00092000
      FREF0 = ONE                                                       00092100
      GO TO 630                                                         00092200
C             FOUND 'REFL' CARD                                         00092300
  610 IF (JSURF.EQ.IZERO) GO TO 615                                     00092400
      FREF(JSURF) = -ONE                                                00092500
      FN(JSURF,1) = ONE                                                 00092600
      FN(JSURF,2) = ONE                                                 00092700
      FN(JSURF,3) = ONE                                                 00092800
      KK=JSURF                                                          00092900
      GO TO 630                                                         00093000
  615 FREF0 = -ONE                                                      00093100
      OBJN(1) = ONE                                                     00093200
      OBJN(2) = ONE                                                     00093300
      OBJN(3) = ONE                                                     00093400
      GO TO 630                                                         00093500
C             FOUND 'GLASS' CARD                                        00093600
  620 IF (JSURF.EQ.IZERO) GO TO 626                                     00093700
      FN(JSURF,1) = ARRAY(1)                                            00093800
      FN(JSURF,2) = ARRAY(2)                                            00093900
      FN(JSURF,3) = ARRAY(3)                                            00094000
      FREF(JSURF) = ONE                                                 00094100
      GO TO 630                                                         00094200
  626 OBJN(1) = ARRAY(1)                                                00094300
      OBJN(2) = ARRAY(2)                                                00094400
      OBJN(3) = ARRAY(3)                                                00094500
      FREF0 = ONE                                                       00094600
C                                                                       00094700
  630 IF (JSURF.EQ.ISURF) ISURF=ISURF+IONE                              00094800
      GO TO 2083                                                        00094900
C                                                                       00095000
C             HERE IF "ASPH" CARD                                       00095100
  640 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00095200
      IF (IWORD1(5).EQ.IBLANK) GO TO 700                                00095300
      GO TO 335                                                         00095400
C             STORE ALL COEFFICIENTS                                    00095500
  700 DO 710 I=1,4                                                      00095600
        COEF(JSURF,I)=ARRAY(I)                                          00095700
  710 CONTINUE                                                          00095800
      GO TO 2083                                                        00095900
C                                                                       00096000
C             HERE IF "CC" CARD                                         00096100
  720 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00096200
      CONIC(JSURF)=ARRAY(1)                                             00096300
      GO TO 2083                                                        00096400
C                                                                       00096500
C             HERE IF "CONC" CARD                                       00096600
  723 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00096700
      SIDE(JSURF) = ONE                                                 00096800
      GO TO 2083                                                        00096900
C                                                                       00097000
C             HERE IF "CONV" CARD                                       00097100
  726 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00097200
      SIDE(JSURF) = -ONE                                                00097300
      GO TO 2083                                                        00097400
C             HERE IF "DEC" CARD                                        00097500
  730 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00097600
C             FOUND BOTH X AND Y DISPLACEMENTS                          00097700
  750 YDISP(JSURF)=ARRAY(1)                                             00097800
      XDISP(JSURF)=ARRAY(2)                                             00097900
      GO TO 2083                                                        00098000
C                                                                       00098100
C             HERE IF "TILT" CARD                                       00098200
  760 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00098300
C             FOUND X,Y, AND Z TILTS                                    00098400
  800 TILTX(JSURF)=ARRAY(1)                                             00098500
      TILTY(JSURF)=ARRAY(2)                                             00098600
      TILTZ(JSURF)=ARRAY(3)                                             00098700
      GO TO 2083                                                        00098800
C                                                                       00098900
C             HERE IF "RTILT" CARD                                      00099000
  810 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00099100
      DO 815 I=1,LEN2                                                   00099200
        IF ( IWORD2(I).EQ.IBLANK ) GO TO 840                            00099300
        IF ( IWORD2(I).EQ.ALPHA(4) .AND. IWORD2(I+1).EQ.ALPHA(5)        00099400
     $     .AND.IWORD2(I+2).EQ.ALPHA(3).AND.IWORD2(I+3).EQ.ALPHA(19))   00099500
     $     GO TO 830                                                    00099600
        IF ( IWORD2(I).EQ.ALPHA(20) .AND. IWORD2(I+1).EQ.ALPHA(9)       00099700
     $     .AND.IWORD2(I+2).EQ.ALPHA(12).AND.IWORD2(I+3).EQ.ALPHA(20)   00099800
     $     .AND.IWORD2(I+4).EQ.ALPHA(19) ) GO TO 820                    00099900
  815 CONTINUE                                                          00100000
      GO TO 840                                                         00100100
C             RESTORE TILTS                                             00100200
  820 FAKEB(JSURF)=TWO                                                  00100300
      GO TO 2083                                                        00100400
C             RESTORE DISPLACEMENTS                                     00100500
  830 FAKEB(JSURF)=ONE                                                  00100600
      GO TO 2083                                                        00100700
C             RESTORE DISPLACEMENTS AND TILTS                           00100800
  840 FAKEB(JSURF)=THREE                                                00100900
      GO TO 2083                                                        00101000
C                                                                       00101100
C             HERE IF "GRAT" OR "GRATD" CARD                            00101200
  850 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00101300
      TEMP=ONE                                                          00101400
        IF ( IWORD1(5).EQ.ALPHA(24) ) GO TO 880                         00101500
        IF ( IWORD1(5).EQ.ALPHA(25) ) GO TO 890                         00101600
        IF ( IWORD1(5).EQ.ALPHA(4) ) GO TO 870                          00101700
      GO TO 890                                                         00101800
C             HERE IF "GORD" CARD                                       00101900
  860 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00102000
      CALL CNTCOM (NCOM,INPUT2(KBEG),LENGTH)                            00102100
      IF (NCOM.GT.1) GO TO 865                                          00102200
        ORDN(JSURF,1) = ARRAY(1)                                        00102300
        ORDN(JSURF,2) = ARRAY(1)                                        00102400
        ORDN(JSURF,3) = ARRAY(1)                                        00102500
      GO TO 2083                                                        00102600
  865   ORDN(JSURF,1) = ARRAY(1)                                        00102700
        ORDN(JSURF,2) = ARRAY(2)                                        00102800
        ORDN(JSURF,3) = ARRAY(3)                                        00102900
      GO TO 2083                                                        00103000
  870 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00103100
      IF (JSURF.GT.ZERO) GO TO 875                                      00103200
C             NO SURFACE SPECIFIED                                      00103300
      WRITE(6,84)                                                       00103400
      GO TO 2083                                                        00103500
  875 RDSPAC(JSURF) = ZERO                                              00103600
      ORDN(JSURF,1) = ZERO                                              00103700
      ORDN(JSURF,2) = ZERO                                              00103800
      ORDN(JSURF,3) = ZERO                                              00103900
      GO TO 2083                                                        00104000
C                                                                       00104100
C             RULINGS ARE X-RULINGS                                     00104200
  880 TEMP=-ONE                                                         00104300
      GO TO 900                                                         00104400
C                                                                       00104500
C             RULINGS ARE Y-RULINGS (DEFAULT)                           00104600
  890 TEMP=ONE                                                          00104700
C                                                                       00104800
C             STORE SPACING                                             00104900
  900 RDSPAC(JSURF)=TEMP*DABS(ARRAY(1))                                 00105000
      GO TO 2083                                                        00105100
C                                                                       00105200
C             HERE IF "CLAP" CARD                                       00105300
  910 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00105400
      IF (IWORD1(5).EQ.ALPHA(4)) GO TO 990                              00105500
      DO 920 I=1,LEN2                                                   00105600
        IF ( IWORD2(I).EQ.IBLANK ) GO TO 930                            00105700
        IF ( IWORD2(I).EQ.ALPHA(18) .AND. IWORD2(I+1).EQ.ALPHA(5)       00105800
     $       .AND.IWORD2(I+2).EQ.ALPHA(3).AND.IWORD2(I+3).EQ.ALPHA(20)) 00105900
     $       GO TO 970                                                  00106000
        IF ( IWORD2(I).EQ.ALPHA(5).AND.IWORD2(I+1).EQ.ALPHA(12)         00106100
     $       .AND.IWORD2(I+2).EQ.ALPHA(9).AND.IWORD2(I+3).EQ.ALPHA(16)) 00106200
     $       GO TO 983                                                  00106300
  920 CONTINUE                                                          00106400
      GO TO 930                                                         00106500
C             MASK IS A CIRCULAR CLEAR APERTURE                         00106600
  930 FMASK(JSURF)=DABS(ARRAY(1))                                       00106700
      YMN(JSURF)=ARRAY(2)                                               00106800
      XMN(JSURF)=ARRAY(3)                                               00106900
      FAKEC(JSURF)=ZERO                                                 00107000
      GO TO 2083                                                        00107100
C             MASK IS A CIRCULAR OBSCURATION                            00107200
  940 FMASK(JSURF)=-DABS(ARRAY(1))                                      00107300
      YMN(JSURF)=ARRAY(2)                                               00107400
      XMN(JSURF)=ARRAY(3)                                               00107500
      FAKEC(JSURF)=ZERO                                                 00107600
      GO TO 2083                                                        00107700
C                                                                       00107800
C             HERE IF "COBS" CARD                                       00107900
  950 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00108000
      IF (IWORD1(5).EQ.ALPHA(4)) GO TO 990                              00108100
      DO 960 I=1,LEN2                                                   00108200
        IF ( IWORD2(I).EQ.IBLANK ) GO TO 940                            00108300
        IF ( IWORD2(I).EQ.ALPHA(18) .AND. IWORD2(I+1).EQ.ALPHA(5)       00108400
     $       .AND.IWORD2(I+2).EQ.ALPHA(3).AND.IWORD2(I+3).EQ.ALPHA(20)) 00108500
     $       GO TO 980                                                  00108600
        IF ( IWORD2(I).EQ.ALPHA(5).AND.IWORD2(I+1).EQ.ALPHA(12)         00108700
     $       .AND.IWORD2(I+2).EQ.ALPHA(9).AND.IWORD2(I+3).EQ.ALPHA(16)) 00108800
     $       GO TO 986                                                  00108900
  960 CONTINUE                                                          00109000
      GO TO 940                                                         00109100
C             MASK IS A RECTANGULAR CLEAR APERTURE                      00109200
  970 YMN(JSURF)=ARRAY(1)                                               00109300
      YMX(JSURF)=ARRAY(2)                                               00109400
      XMN(JSURF)=ARRAY(3)                                               00109500
      XMX(JSURF)=ARRAY(4)                                               00109600
      FAKEC(JSURF)=ONE                                                  00109700
      FMASK(JSURF)=ONE                                                  00109800
      GO TO 2083                                                        00109900
C             MASK IS A RECTANGULAR OBSCURATION                         00110000
  980 YMN(JSURF)=ARRAY(1)                                               00110100
      YMX(JSURF)=ARRAY(2)                                               00110200
      XMN(JSURF)=ARRAY(3)                                               00110300
      XMX(JSURF)=ARRAY(4)                                               00110400
      FAKEC(JSURF)=ONE                                                  00110500
      FMASK(JSURF)=-ONE                                                 00110600
      GO TO 2083                                                        00110700
C                                                                       00110800
C              MAP IS ELLIPTICAL CLEAR APERTURE                         00110900
C                                                                       00111000
  983   YMX(JSURF)=ARRAY(1)                                             00111100
        XMX(JSURF)=ARRAY(2)                                             00111200
        YMN(JSURF)=ARRAY(3)                                             00111300
        XMN(JSURF)=ARRAY(4)                                             00111400
        FAKEC(JSURF)=-ONE                                               00111500
        FMASK(JSURF)=ONE                                                00111600
        GO TO 2083                                                      00111700
C                                                                       00111800
C              MAP IS ELLIPTICAL OBSCURATION                            00111900
C                                                                       00112000
  986   YMX(JSURF)=ARRAY(1)                                             00112100
        XMX(JSURF)=ARRAY(2)                                             00112200
        YMN(JSURF)=ARRAY(3)                                             00112300
        XMN(JSURF)=ARRAY(4)                                             00112400
        FAKEC(JSURF)=-ONE                                               00112500
        FMASK(JSURF)=-ONE                                               00112600
        GO TO 2083                                                      00112700
C                                                                       00112800
C             HERE IF "CLAPD" CARD OR "COBSD" CARD                      00112900
C                                                                       00113000
  990 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00113100
      IF (JSURF.GT.ZERO) GO TO 1000                                     00113200
C             SURFACE NOT SPECIFIED                                     00113300
      WRITE(6,85)                                                       00113400
      GO TO 2083                                                        00113500
 1000 FMASK(JSURF)=ZERO                                                 00113600
      FAKEC(JSURF)=ZERO                                                 00113700
      XMN(JSURF)=ZERO                                                   00113800
      XMX(JSURF)=ZERO                                                   00113900
      YMN(JSURF)=ZERO                                                   00114000
      YMX(JSURF)=ZERO                                                   00114100
      GO TO 2083                                                        00114200
C                                                                       00114300
C             HERE IF "PXTY" CARD                                       00114400
C             DETERMINE MAXIMUM SURFACE NUMBER                          00114500
C             THIS IS DETERMINED BY FIRST SURFACE WITH A ZERO INDEX     00114600
 1060 DO 1070 I=1,40                                                    00114700
        IF ( FN(I,1).EQ.ZERO ) GO TO 1080                               00114800
 1070 CONTINUE                                                          00114900
 1080 ISURF=I                                                           00115000
      NSURF=ISURF-IONE                                                  00115100
C             CHANGE LINEAR HEIGHTS TO ANGLES                           00115200
 1084 IF (IFLAG.EQ.0) GO TO 1086                                        00115300
      HXDEL=-DATAN(HXDEL/(S-D))*(180.D0/PI)                             00115400
      HYDEL=-DATAN(HYDEL/(S-D))*(180.D0/PI)                             00115500
      HXINIT=-DATAN(HXINIT/(S-D))*(180.D0/PI)                           00115600
      HYINIT=-DATAN(HYINIT/(S-D))*(180.D0/PI)                           00115700
 1086 IF ((IPRINT/2)*2.NE.IPRINT) GO TO 1111                            00115800
C             DETERMINE COLORS FROM CARD                                00115900
      CALL CNTCOM (NCOM,INPUT2(KBEG),LENGTH)                            00116000
      IF (NCOM.GT.IZERO) GO TO 1090                                     00116100
C             CAN'T IDENTIFY COLORS                                     00116200
      WRITE (6,90)                                                      00116300
      GO TO 2083                                                        00116400
 1090 IF (NCOM.GT.ITHREE) NCOM=ITHREE                                   00116500
      NCOL=NCOM                                                         00116600
      DO 1100 I=1,NCOL                                                  00116700
        ICOL(I)=ARRAY(I)                                                00116800
        IF (ICOL(I).LT.1) ICOL(I)=1                                     00116900
        IF (ICOL(I).GT.3) ICOL(I)=3                                     00117000
 1100 CONTINUE                                                          00117100
C             CONVERT WAVELENGTH FROM NANOMETERS TO SYSTEM UNITS        00117200
      DO 1105 I=1,NCOL                                                  00117300
      IF (UFLAG.EQ.ONE) WAVL(I)=WAVE(ICOL(I))*1.D-6                     00117400
      IF (UFLAG.EQ.TWO) WAVL(I)=WAVE(ICOL(I))*1.D-7                     00117500
      IF (UFLAG.EQ.THREE) WAVL(I)=(WAVE(ICOL(I))*1.D-6)/25.4D0          00117600
 1105 CONTINUE                                                          00117700
 1111 WRITE (6,40)                                                      00117800
      CALL PARAX                                                        00117900
      WRITE (6,40)                                                      00118000
      GO TO 2083                                                        00118100
C                                                                       00118200
C             HERE IF "SCY" CARD                                        00118300
 1110 IF (IWORD2(1).EQ.IBLANK)    GO TO 1150                            00118400
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(1)               00118500
     $     .AND.IWORD2(3).EQ.ALPHA(14).AND.IWORD2(4).EQ.ALPHA(7))       00118600
     $     GO TO 1140                                                   00118700
C             CAN'T IDENTIFY WORD2 ON "SCY" CARD                        00118800
      WRITE(6,100) IWORD2                                               00118900
      GO TO 2083                                                        00119000
C             FOUND "FANG" AS 2ND WORD                                  00119100
 1140 RNOBJ=ARRAY(1)                                                    00119200
      HINIT=ARRAY(2)                                                    00119300
      HDEL=ARRAY(3)                                                     00119400
      IFLAG = IZERO                                                     00119500
      GO TO 1160                                                        00119600
C             FOUND BLANK AS 2ND WORD                                   00119700
 1150 RNOBJ=ARRAY(1)                                                    00119800
      IFLAG = IONE                                                      00119900
      HINIT=ARRAY(2)                                                    00120000
      HDEL=ARRAY(3)                                                     00120100
 1160 IF (IWORD1(3).EQ.ALPHA(24)) GO TO 1180                            00120200
      IF (IWORD1(3).EQ.ALPHA(25)) GO TO 1170                            00120300
C              CAN'T IDENTIFY WORD2 ON "SCY" OR "SCX" CARD              00120400
      WRITE (6,100) IWORD2                                              00120500
      GO TO 2083                                                        00120600
C             FOUND Y OBJECT                                            00120700
 1170 HYINIT=HINIT                                                      00120800
      HYDEL=HDEL                                                        00120900
      GO TO 2083                                                        00121000
C             FOUND X OJECT                                             00121100
 1180 HXINIT=HINIT                                                      00121200
      HXDEL=HDEL                                                        00121300
      GO TO 2083                                                        00121400
C                                                                       00121500
C             HERE IF "IMAGE" CARD                                      00121600
 1240 IF (IWORD2(1).EQ.IBLANK) GO TO 1310                               00121700
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(4))             00121800
     $     GO TO 1250                                                   00121900
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(9)               00122000
     $     .AND.IWORD2(3).EQ.ALPHA(18).AND.IWORD2(4).EQ.ALPHA(19)       00122100
     $     .AND.IWORD2(5).EQ.ALPHA(20)) GO TO 1260                      00122200
      IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(21)             00122300
     $     .AND.IWORD2(3).EQ.ALPHA(18).AND.IWORD2(4).EQ.ALPHA(6))       00122400
     $     GO TO 1270                                                   00122500
      IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(5)              00122600
     $     .AND.IWORD2(3).EQ.ALPHA(16)) GO TO 1280                      00122700
      IF (IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(3))   GO TO 1290 00122800
      IF (IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(22))  GO TO 1300 00122900
      GO TO 335                                                         00123000
C                                                                       00123100
C             FOUND RADIUS                                              00123200
 1250 RADIMG=ARRAY(1)                                                   00123300
      GO TO 1320                                                        00123400
C             FOUND FIRST IMAGE SURFACE NUMBER                          00123500
 1260 FPLANE=ARRAY(1)                                                   00123600
      GO TO 1320                                                        00123700
C             FOUND NUMBER OF IMAGE SURFACES                            00123800
 1270 NPLANE=ARRAY(1)                                                   00123900
      GO TO 1320                                                        00124000
C             FOUND IMAGE SURFACE SEPARATION                            00124100
 1280 DELIMP=ARRAY(1)                                                   00124200
      GO TO 1320                                                        00124300
C             FOUND IMAGE SURFACE CONIC CONSTANT                        00124400
 1290 CONIMG=ARRAY(1)                                                   00124500
      GO TO 1320                                                        00124600
C             FOUND IMAGE CURVATURE                                     00124700
 1300 CVIMG=ARRAY(1)                                                    00124800
      GO TO 1320                                                        00124900
C             FOUND BLANK, EVERYTHING IS ON ONE CARD                    00125000
 1310 NPLANE=ARRAY(1)                                                   00125100
      RADIMG=ARRAY(2)                                                   00125200
      CVIMG=ARRAY(3)                                                    00125300
      CONIMG=ARRAY(4)                                                   00125400
      DELIMP=ARRAY(5)                                                   00125500
      FPLANE=ARRAY(6)                                                   00125600
C                                                                       00125700
 1320 IF (RADIMG.NE.ZERO) CVIMG=ONE/RADIMG                              00125800
      IF (RADIMG.EQ.ZERO.AND.CVIMG.NE.ZERO) RADIMG=ONE/CVIMG            00125900
      IF (FPLANE.NE.ZERO) GO TO 2083                                    00126000
      M=IONE+NPLANE/ITWO                                                00126100
      M=M-IONE                                                          00126200
      FPLANE=-M                                                         00126300
      GO TO 2083                                                        00126400
C                                                                       00126500
C             HERE IF "UNITS" CARD                                      00126600
 1340 IF (IWORD2(1).EQ.ALPHA(13).AND.IWORD2(2).EQ.ALPHA(13)) GO TO 1350 00126700
      IF (IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(13))  GO TO 1360 00126800
      IF (IWORD2(1).EQ.ALPHA(9).AND.IWORD2(2).EQ.ALPHA(14)              00126900
     $     .AND.IWORD2(3).EQ.ALPHA(3).AND.IWORD2(4).EQ.ALPHA(8)         00127000
     $     .AND.IWORD2(5).EQ.ALPHA(5).AND.IWORD2(6).EQ.ALPHA(19))       00127100
     $     GO TO 1370                                                   00127200
C             AT THIS POINT, UNKNOWN UNITS                              00127300
      WRITE (6,110) IWORD2                                              00127400
      GO TO 2083                                                        00127500
C                                                                       00127600
C             UNITS ARE MILLIMETERS                                     00127700
 1350 IF (OFLAG.EQ.ZERO) UFLAG=ONE                                      00127800
      IF (OFLAG.NE.ZERO) OFLAG=ONE                                      00127900
      GO TO 2083                                                        00128000
C             UNITS ARE CENTIMETERS                                     00128100
 1360 IF (OFLAG.EQ.ZERO) UFLAG=TWO                                      00128200
      IF (OFLAG.NE.ZERO) OFLAG=TWO                                      00128300
      GO TO 2083                                                        00128400
C             UNITS ARE INCHES                                          00128500
 1370 IF (OFLAG.EQ.ZERO) UFLAG=THREE                                    00128600
      IF (OFLAG.NE.ZERO) OFLAG=THREE                                    00128700
      GO TO 2083                                                        00128800
C                                                                       00128900
C             HERE IF "MODE" CARD                                       00129000
C                                                                       00129100
 1375 IF (IWORD2(1).EQ.ALPHA(1).AND.IWORD2(2).EQ.ALPHA(6)               00129200
     $     .AND.IWORD1(3).EQ.ALPHA(15).AND.IWORD1(4).EQ.ALPHA(3)        00129300
     $     .AND.IWORD1(5).EQ.ALPHA(1).AND.IWORD1(6).EQ.ALPHA(12))       00129400
     $     GO TO 1380                                                   00129500
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(15)              00129600
     $     .AND.IWORD2(3).EQ.ALPHA(3).AND.IWORD2(4).EQ.ALPHA(1)         00129700
     $     .AND.IWORD2(5).EQ.ALPHA(12)) GO TO 1395                      00129800
      IF (IWORD1(1).EQ.ALPHA(1).AND.IWORD1(2).EQ.ALPHA(14)              00129900
     $     .AND.IWORD1(3).EQ.ALPHA(7).AND.IWORD1(4).EQ.ALPHA(12)        00130000
     $     .AND.IWORD1(5).EQ.ALPHA(5).AND.IWORD1(6).EQ.ALPHA(19))       00130100
     $     GO TO 1390                                                   00130200
C             AT THIS POINT, UNKNOWN MODE                               00130300
      WRITE(6,112) IWORD2                                               00130400
      GO TO 2083                                                        00130500
C      OUTPUT UNITS ARE TANGENTS OF ANGLES (W/ RESPECT TO AXIS)         00130600
 1380 IF (OFLAG.EQ.ZERO) OFLAG=UFLAG                                    00130700
      UFLAG=FOUR                                                        00130800
      GO TO 2083                                                        00130900
C      OUTPUT UNITS ARE ANGLES OF INCIDENCE(W/ RESPECT TO NORMAL)       00131000
 1390 IF (OFLAG.EQ.ZERO) OFLAG=UFLAG                                    00131100
      UFLAG=FIVE                                                        00131200
      GO TO 2083                                                        00131300
C      RETURN TO FOCAL MODE                                             00131400
 1395 IF (OFLAG.NE.ZERO) UFLAG=OFLAG                                    00131500
      OFLAG=ZERO                                                        00131600
      GO TO 2083                                                        00131700
C                                                                       00131800
C             HERE IF "FOCUS" CARD                                      00131900
C             FIRST TEST TO SEE IF SKEW ALREADY CALLED                  00132000
 1400 IF (ISKEW.NE.IZERO) GO TO 1410                                    00132100
C             HAVEN'T CALLED SKEW YET, BEFORE FOCUS                     00132200
      WRITE (6,120)                                                     00132300
      GO TO 2083                                                        00132400
 1410 OBJNO=ARRAY(1)                                                    00132500
      COLNO=ARRAY(2)                                                    00132600
      IF (OBJNO.EQ.ZERO) OBJNO=ONE                                      00132700
      IF (COLNO.EQ.ZERO) COLNO=ONE                                      00132800
      FCODE=THREE*(OBJNO-ONE)+COLNO                                     00132900
      NFOC=OBJNO                                                        00133000
      LFOC=COLNO                                                        00133100
      IF (IWORD2(1).EQ.IBLANK.OR.IWORD2(1).EQ.ALPHA(19)) IFOC=IZERO     00133200
      IF (IWORD2(1).EQ.ALPHA(24)) IFOC=-IONE                            00133300
      IF (IWORD2(1).EQ.ALPHA(25)) IFOC=IONE                             00133400
      GO TO 2083                                                        00133500
C                                                                       00133600
C             HERE IF "CFL" CARD (FOCAL LENGTH)                         00133700
 1420 FOCL=ARRAY(1)                                                     00133800
      GO TO 2083                                                        00133900
C                                                                       00134000
C             HERE IF "SAG" CARD                                        00134100
 1430 IF ( IWORD2(1).EQ.IBLANK ) GO TO 1437                             00134200
      IF ( IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(21)            00134300
     $     .AND.IWORD2(3).EQ.ALPHA(18).AND.IWORD2(4).EQ.ALPHA(6))       00134400
     $     GO TO 1431                                                   00134500
      IF ( IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(1) .AND.       00134600
     $     IWORD2(3).EQ.ALPHA(14).AND.IWORD2(4).EQ.ALPHA(7)             00134700
     $     .AND.IWORD2(5).EQ.ALPHA(5)) GO TO 1432                       00134800
      IF ( IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(15)             00134900
     $     .AND.IWORD2(3).EQ.ALPHA(14).AND.IWORD2(4).EQ.ALPHA(19)       00135000
     $     .AND.IWORD2(5).EQ.ALPHA(20)) GO TO 1433                      00135100
      IF ( IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(4) ) GO TO 143400135200
      IF ( IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(22) ) GO TO 143500135300
      IF ( IWORD2(1).EQ.ALPHA(23).AND.IWORD2(2).EQ.ALPHA(22)) GO TO 143600135400
      GO TO 335                                                         00135500
C             FOUND "SURF" AS WORD 2                                    00135600
 1431 ISRF=ARRAY(1)                                                     00135700
      GO TO 2083                                                        00135800
C             FOUND "RANGE" AS WORD 2                                   00135900
 1432 YMIN=ARRAY(1)                                                     00136000
      YMAX=ARRAY(2)                                                     00136100
      DELY=ARRAY(3)                                                     00136200
      GO TO 2083                                                        00136300
C             FOUND "CONST" AS WORD 2                                   00136400
 1433 CONST=ARRAY(1)                                                    00136500
      GO TO 2083                                                        00136600
C             FOUND "RD" AS WORD 2                                      00136700
 1434 REFRAD = ARRAY(1)                                                 00136800
      REFCRV = ZERO                                                     00136900
      IF ( REFRAD.NE.ZERO ) REFCRV = ONE/REFRAD                         00137000
      GO TO 2083                                                        00137100
C             FOUND "CV" AS WORD 2                                      00137200
 1435 REFCRV = ARRAY(1)                                                 00137300
      GO TO 2083                                                        00137400
C             FOUND "WV" AS WORD 2                                      00137500
 1436 WAVENM = ARRAY(1)                                                 00137600
      GO TO 2083                                                        00137700
C             FOUND BLANK, EVERYTHING IS ON ONE LINE                    00137800
 1437 ISRF=ARRAY(1)                                                     00137900
      YMIN=ARRAY(2)                                                     00138000
      YMAX=ARRAY(3)                                                     00138100
      DELY=ARRAY(4)                                                     00138200
      REFCRV=ARRAY(5)                                                   00138300
      CONST=ARRAY(6)                                                    00138400
      WAVENM=ARRAY(7)                                                   00138500
      GO TO 2083                                                        00138600
C                                                                       00138700
C             HERE IF "LI" OR "LIC" CARD                                00138800
 1440 IF ( IWORD1(3).EQ.IBLANK )   GO TO 1470                           00138900
      IF ( IWORD1(3).EQ.ALPHA(3)) GO TO 1450                            00139000
      GO TO 335                                                         00139100
C             FOUND PLOT LABEL                                          00139200
 1450 K=L2B                                                             00139300
      IF (INPUT2(L1).EQ.IVAL) K=L2                                      00139400
      DO 1460 I=1,25                                                    00139500
        NAME(80+I)=INPUT2(K+I-IONE)                                     00139600
 1460 CONTINUE                                                          00139700
      GO TO 2083                                                        00139800
C             HERE IF "LI" CARD                                         00139900
C             FOUND LABEL USED FOR PRINTED OUTPUT                       00140000
 1470 J=IZERO                                                           00140100
      K=L2B                                                             00140200
      IF (INPUT2(L1).EQ.IVAL) K=L2                                      00140300
      DO 1480 I=K,80                                                    00140400
        J=J+IONE                                                        00140500
        NAME(J)=INPUT2(I)                                               00140600
 1480 CONTINUE                                                          00140700
      GO TO 2083                                                        00140800
C                                                                       00140900
C                                                                       00141000
C             HERE IF "PLOT" CARD                                       00141100
 1490 IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(16)             00141200
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1950                       00141300
      IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(3)              00141400
     $     .AND.IWORD2(3).EQ.ALPHA(1).AND.IWORD2(4).EQ.ALPHA(12)        00141500
     $     .AND.IWORD2(5).EQ.ALPHA(5)) GO TO 1498                       00141600
      IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(15)              00141700
     $     .AND.IWORD2(3).EQ.ALPHA(20).AND.IWORD2(4).EQ.ALPHA(6))       00141800
     $     GO TO 1760                                                   00141900
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00142000
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1810                       00142100
      IF (IWORD2(1).EQ.ALPHA(15).AND.IWORD2(2).EQ.ALPHA(16)             00142200
     $     .AND.IWORD2(3).EQ.ALPHA(19).AND.IWORD2(4).EQ.ALPHA(16))      00142300
     $     GO TO 1945                                                   00142400
C             AT THIS POINT, UNIDENTIFIED PLOT OPTION                   00142500
      WRITE(6,124) IWORD2                                               00142600
      GO TO 2083                                                        00142700
C                                                                       00142800
C             HERE IF "NOPLOT" CARD                                     00142900
C                                                                       00143000
 1492 IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(16)             00143100
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1960                       00143200
      IF (IWORD2(1).EQ.ALPHA(15).AND.IWORD2(2).EQ.ALPHA(16)             00143300
     $     .AND.IWORD2(3).EQ.ALPHA(19).AND.IWORD2(4).EQ.ALPHA(16))      00143400
     $     GO TO 1960                                                   00143500
      IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(15)              00143600
     $     .AND.IWORD2(3).EQ.ALPHA(20).AND.IWORD2(4).EQ.ALPHA(6))       00143700
     $     GO TO 1770                                                   00143800
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00143900
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1820                       00144000
      IF (IWORD2(1).EQ.ALPHA(15).AND.IWORD2(2).EQ.ALPHA(16)             00144100
     $     .AND.IWORD2(3).EQ.ALPHA(19).AND.IWORD2(4).EQ.ALPHA(16))      00144200
     $     GO TO 1965                                                   00144300
      GO TO 2083                                                        00144400
C                                                                       00144500
C             HERE IF "PRINT" CARD                                      00144600
C                                                                       00144700
 1494 IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(15)              00144800
     $     .AND.IWORD2(3).EQ.ALPHA(20).AND.IWORD2(4).EQ.ALPHA(6))       00144900
     $     GO TO 1740                                                   00145000
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00145100
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1790                       00145200
      IF (IWORD2(1).EQ.ALPHA(16).AND.IWORD2(2).EQ.ALPHA(18)             00145300
     $     .AND.IWORD2(3).EQ.ALPHA(24).AND.IWORD2(4).EQ.ALPHA(25)       00145400
     $     .AND.IWORD2(5).EQ.ALPHA(26)) GO TO 1850                      00145500
      IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(20)             00145600
     $     .AND.IWORD2(3).EQ.ALPHA(1).AND.IWORD2(4).EQ.ALPHA(20)        00145700
     $     .AND.IWORD2(5).EQ.ALPHA(16).AND.IWORD2(6).EQ.ALPHA(19))      00145800
     $     GO TO 2040                                                   00145900
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00146000
     $     .AND.IWORD2(3).EQ.ALPHA(6)) GO TO 2070                       00146100
C             AT THIS POINT, UNIDENTIFIED PRINT OPTION                  00146200
      WRITE(6,126) IWORD2                                               00146300
      GO TO 2083                                                        00146400
C                                                                       00146500
C             HERE IF "NOPRNT" CARD                                     00146600
C                                                                       00146700
 1496 IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(15)              00146800
     $     .AND.IWORD2(3).EQ.ALPHA(20).AND.IWORD2(4).EQ.ALPHA(6))       00146900
     $     GO TO 1750                                                   00147000
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00147100
     $     .AND.IWORD2(3).EQ.ALPHA(4)) GO TO 1800                       00147200
      IF (IWORD2(1).EQ.ALPHA(16).AND.IWORD2(2).EQ.ALPHA(18)             00147300
     $     .AND.IWORD2(3).EQ.ALPHA(24).AND.IWORD2(4).EQ.ALPHA(25)       00147400
     $     .AND.IWORD2(5).EQ.ALPHA(26)) GO TO 1860                      00147500
      IF (IWORD2(1).EQ.ALPHA(19).AND.IWORD2(2).EQ.ALPHA(20)             00147600
     $     .AND.IWORD2(3).EQ.ALPHA(1).AND.IWORD2(4).EQ.ALPHA(20)        00147700
     $     .AND.IWORD2(5).EQ.ALPHA(16).AND.IWORD2(6).EQ.ALPHA(19))      00147800
     $     GO TO 2050                                                   00147900
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00148000
     $     .AND.IWORD2(3).EQ.ALPHA(6)) GO TO 2080                       00148100
      GO TO 2083                                                        00148200
C             FOUND "SCALE" AS SECOND WORD                              00148300
 1498 XSMIN=ARRAY(1)                                                    00148400
      XSMAX=ARRAY(2)                                                    00148500
      YSMIN=ARRAY(3)                                                    00148600
      YSMAX=ARRAY(4)                                                    00148700
      GO TO 2083                                                        00148800
C             HERE IF "SAY" CARD                                        00148900
 1500 IF ( IWORD2(1).NE.IBLANK )  GO TO 335                             00149000
 1508 RHO=ARRAY(1)                                                      00149100
      D=ARRAY(2)                                                        00149200
      GO TO 2083                                                        00149300
C                                                                       00149400
C             HERE IF "DES" CARD                                        00149500
C             TEST TO SEE IF PARAX CALLED YET                           00149600
 1510 IF (IPARAX.NE.IZERO) GO TO 1520                                   00149700
C             TRIED TELDESIGN BEFORE CALLING PARAX                      00149800
      WRITE (6,130)                                                     00149900
      GO TO 2083                                                        00150000
 1520 IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(3)) GO TO 1530  00150100
      IF (IWORD2(1).EQ.ALPHA(3).AND.IWORD2(2).EQ.ALPHA(1)) GO TO 1540   00150200
      IF (IWORD2(1).EQ.ALPHA(4).AND.IWORD2(2).EQ.ALPHA(11)) GO TO 1550  00150300
C             UNKNOWN TYPE OF DESIGN                                    00150400
      WRITE (6,140) IWORD2                                              00150500
      GO TO 2083                                                        00150600
C             RITCHEY-CHRETIEN DESIGN                                   00150700
 1530 CALL RCDES                                                        00150800
      GO TO 2083                                                        00150900
C             CASSEGRAIN DESIGN                                         00151000
 1540 CALL CADES                                                        00151100
      GO TO 2083                                                        00151200
C             DAHL-KIRKHAM DESIGN                                       00151300
 1550 CALL DKDES                                                        00151400
      GO TO 2083                                                        00151500
C                                                                       00151600
C             HERE IF "ASTOP" CARD                                      00151700
 1560 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00151800
      APSTOP=DFLOAT(JSURF)                                              00151900
      IAP=APSTOP                                                        00152000
      APSTOP=APSTOP*30.D0                                               00152100
      IF (APSTOP.LT.ZERO) APSTOP=ZERO                                   00152200
      GO TO 2083                                                        00152300
C                                                                       00152400
C             HERE IF "LATT" CARD                                       00152500
 1566 LATFLG=IONE                                                       00152600
      DO 1567 I=1,10                                                    00152700
      IF (IWORD2(1).EQ.NUM(I)) GO TO 1568                               00152800
 1567 CONTINUE                                                          00152900
      IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(5)               00153000
     $     .AND.IWORD2(3).EQ.ALPHA(14)) GO TO 1568                      00153100
      GO TO 335                                                         00153200
 1568 CALL CNTCOM(NCOM,INPUT2(KBEG),LENGTH)                             00153300
      IF (NCOM.LE.IZERO.OR.NCOM.GT.20) GO TO 2083                       00153400
      DO 1569 I=1,NCOM                                                  00153500
        CLTRA(INDEX)=ARRAY(I)                                           00153600
        INDEX=INDEX+IONE                                                00153700
 1569 CONTINUE                                                          00153800
      LATYPE=ITHREE                                                     00153900
      GO TO 2083                                                        00154000
C                                                                       00154100
C             HERE IF "SPD" CARD                                        00154200
 1570 IMODE=IZERO                                                       00154300
      NNSW=IZERO                                                        00154400
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(5)              00154500
     $     .AND.IWORD2(3).EQ.ALPHA(3)) GO TO 1590                       00154600
      IF (IWORD2(1).EQ.ALPHA(16).AND.IWORD2(2).EQ.ALPHA(15)             00154700
     $     .AND.IWORD2(3).EQ.ALPHA(12)) GO TO 1640                      00154800
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(9)               00154900
     $     .AND.IWORD2(3).EQ.ALPHA(14)) GO TO 1650                      00155000
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(1)              00155100
     $     .AND.IWORD2(3).EQ.ALPHA(25)) GO TO 1660                      00155200
      IF (IWORD2(1).EQ.ALPHA(7).AND.IWORD2(2).EQ.ALPHA(5)               00155300
     $     .AND.IWORD2(3).EQ.ALPHA(14)) GO TO 1670                      00155400
      IF (IWORD2(2).EQ.ALPHA(6).AND.IWORD2(3).EQ.ALPHA(1)               00155500
     $     .AND.IWORD2(4).EQ.ALPHA(14)) GO TO 1690                      00155600
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(9)               00155700
     $     .AND.IWORD2(3).EQ.ALPHA(12).AND.IWORD2(4).EQ.ALPHA(5))       00155800
     $     GO TO 1585                                                   00155900
      IF (IWORD2(1).EQ.ALPHA(15).AND.IWORD2(2).EQ.ALPHA(16)             00156000
     $     .AND.IWORD2(3).EQ.ALPHA(6).AND.IWORD2(4).EQ.ALPHA(9)         00156100
     $     .AND.IWORD2(5).EQ.ALPHA(12).AND.IWORD2(6).EQ.ALPHA(5))       00156200
     $     GO TO 1583                                                   00156300
      IF (IWORD2(1).EQ.ALPHA(18).AND.IWORD2(2).EQ.ALPHA(9)              00156400
     $     .AND.IWORD2(3).EQ.ALPHA(13)) GO TO 1587                      00156500
      DO 1580 I=1,10                                                    00156600
        IF (IWORD2(1).EQ.NUM(I)) GO TO 1670                             00156700
 1580 CONTINUE                                                          00156800
C             UNKNOWN RAY LATTICE TYPE                                  00156900
      WRITE (6,150) IWORD2                                              00157000
      GO TO 2083                                                        00157100
C             LATTICE ALREADY STORED ON UNIT 20                         00157200
C             WANT TO ANALYZE MANY OBJECT POINTS AT SAME TIME           00157300
 1583 LATYPE=6                                                          00157400
      NNSW=-1                                                           00157500
      GO TO 1721                                                        00157600
C             LATTICE ALREADY STORED ON UNIT 20                         00157700
C             WANT TO ANALYZE ONE OBJECT POINT AT A TIME                00157800
 1585 LATYPE=5                                                          00157900
      NNSW=-1                                                           00158000
      GO TO 1721                                                        00158100
C             RIM LATTICE                                               00158200
 1587 CLTRA(1)=ARRAY(1)                                                 00158300
      NUMPTS=CLTRA(1)                                                   00158400
      DTHETA=(2*PI/CLTRA(1))                                            00158500
      CLTRA(2)=DTHETA                                                   00158600
      LATYPE=7                                                          00158700
      GO TO 1721                                                        00158800
C             RECTANGULAR LATTICE                                       00158900
 1590 CLTRA(1)=ARRAY(1)                                                 00159000
      NUMPTS=CLTRA(1)                                                   00159100
      DX=DSQRT(PI/CLTRA(1))                                             00159200
      DX2=DX/TWO                                                        00159300
      DY=DX                                                             00159400
      DY2=DX2                                                           00159500
      CLTRA(2)=DY                                                       00159600
C             INITIALIZE COUNTERS                                       00159700
      J=IZERO                                                           00159800
      N=IZERO                                                           00159900
C             INITIALIZE FIRST COLUMN LOCATION IN X                     00160000
      X=-DX2                                                            00160100
C             START (IMPLIED) COLUMN LOOP                               00160200
 1600 X=X+DX                                                            00160300
      IF (X.GT.ONE) GO TO 1630                                          00160400
C             K IS NUMBER OF POINTS IN THIS COLUMN;                     00160500
C             J IS USED FOR GENERATING CLTRA ARRAY;                     00160600
      K=IZERO                                                           00160700
      J=J+ITHREE                                                        00160800
C             INITIALIZE Y FOR THIS COLUMN                              00160900
      M=(DSQRT(ONE-X*X)-DY2)/DY                                         00161000
      M=M+IONE                                                          00161100
      Y=DY2-M*DY                                                        00161200
      IF (DSQRT(X*X+Y*Y).GT.ONE) GO TO 1600                             00161300
C             SET UP CLTRA ARRAY FOR THIS COLUMN                        00161400
      CLTRA(J+IONE)=X                                                   00161500
      CLTRA(J+ITWO)=Y                                                   00161600
C             START ROW (IMPLIED) LOOP                                  00161700
 1610 K=K+IONE                                                          00161800
      N=N+IONE                                                          00161900
      Y=Y+DY                                                            00162000
      IF (DSQRT(X*X+Y*Y).GT.ONE) GO TO 1620                             00162100
      GO TO 1610                                                        00162200
C             FINISHED COUNTING ROWS IN THIS COLUMN, GO TO NEXT COLUMN  00162300
 1620 CLTRA(J)=K                                                        00162400
      GO TO 1600                                                        00162500
C             FINISHED GENERATING RECTANGULAR ARRAY                     00162600
 1630 CLTRA(1)=N                                                        00162700
      LATYPE=ITHREE                                                     00162800
      GO TO 1721                                                        00162900
C                                                                       00163000
C             POLAR LATTICE                                             00163100
 1640 ANNULI   = DSQRT( ARRAY(1) )                                      00163200
      IANN     = ANNULI/TWO                                             00163300
      ANNULI   = IANN * ITWO                                            00163400
      ISECT    = ARRAY(1) / ANNULI                                      00163500
      ISECT    = (ISECT/ITWO) * ITWO                                    00163600
      SECTRS   = ISECT                                                  00163700
      CLTRA(1) = ANNULI                                                 00163800
      CLTRA(2) = SECTRS                                                 00163900
      LATYPE   = ITWO                                                   00164000
      GO TO 1721                                                        00164100
C             FINRAY LATTICE                                            00164200
 1650 CLTRA(1)=ARRAY(1)                                                 00164300
      LATYPE=IFOUR                                                      00164400
      GO TO 1721                                                        00164500
C             SINGLE RAY                                                00164600
 1660 CLTRA(1)=ARRAY(1)                                                 00164700
      CLTRA(2)=ARRAY(2)                                                 00164800
      NNSW=IONE                                                         00164900
      LATYPE=IONE                                                       00165000
      IMODE=ITWO                                                        00165100
      GO TO 1721                                                        00165200
C              GENERAL LATTICE                                          00165300
 1670 IF (LATFLG.EQ.IONE) GO TO 1685                                    00165400
C              LATT GEN NOT CALLED YET                                  00165500
      WRITE(6,95)                                                       00165600
      GO TO 2083                                                        00165700
 1685 LATYPE=ITHREE                                                     00165800
      NNSW=-1                                                           00165900
      GO TO 1721                                                        00166000
C                                                                       00166100
C             RAY FAN                                                   00166200
 1690 CLTRA(1)=ARRAY(1)                                                 00166300
      DELTA=TWO/(ARRAY(1)-ONE)                                          00166400
      LATYPE=ITHREE                                                     00166500
      IMODE=ITWO                                                        00166600
      IF (IWORD2(1).EQ.ALPHA(24)) GO TO 1710                            00166700
      IF (IWORD2(1).EQ.ALPHA(25)) GO TO 1700                            00166800
C             UNKNOWN TYPE OF RAY FAN                                   00166900
      WRITE (6,160) IWORD2                                              00167000
      GO TO 1721                                                        00167100
C             YFAN OF RAYS                                              00167200
 1700 CLTRA(2)=DELTA                                                    00167300
      CLTRA(3)=ARRAY(1)                                                 00167400
      CLTRA(4)=ZERO                                                     00167500
      CLTRA(5)=-ONE                                                     00167600
      GO TO 1721                                                        00167700
C             XFAN OF RAYS                                              00167800
 1710 CLTRA(2)=ZERO                                                     00167900
      NRAYS=CLTRA(1)                                                    00168000
      J=ITHREE                                                          00168100
      DO 1720 I=1,NRAYS                                                 00168200
        CLTRA(J)=ONE                                                    00168300
        CLTRA(J+IONE)=-ONE+(I-1)*DELTA                                  00168400
        CLTRA(J+ITWO)=ZERO                                              00168500
        J=J+ITHREE                                                      00168600
 1720 CONTINUE                                                          00168700
C                                                                       00168800
C             PERFORM REAL RAY TRACE                                    00168900
C             DETERMINE MAXIMUM SURFACE NUMBER                          00169000
C             THIS IS DETERMINED BY FIRST SURFACE WITH A ZERO INDEX     00169100
 1721 DO 1722 I=1,40                                                    00169200
        IF ( FN(I,1).EQ.ZERO ) GO TO 1723                               00169300
 1722 CONTINUE                                                          00169400
 1723 ISURF=I                                                           00169500
      NSURF=ISURF-IONE                                                  00169600
      ISKEW=IONE                                                        00169700
      IF ((IPRINT/2)*2.NE.IPRINT) GO TO 1726                            00169800
C             DETERMINE COLORS FROM CARD                                00169900
      CALL CNTCOM (NCOM,INPUT2(KBEG),LENGTH)                            00170000
      IF (NCOM.GT.IONE+NNSW) GO TO 1724                                 00170100
C             CAN'T IDENTIFY COLORS                                     00170200
      WRITE (6,90)                                                      00170300
      GO TO 2083                                                        00170400
 1724 IF (NCOM.GT.4+NNSW) NCOM=4+NNSW                                   00170500
      NCOL=NCOM-(1+NNSW)                                                00170600
      DO 1725 I=1,NCOL                                                  00170700
        ICOL(I)=ARRAY(I+1+NNSW)                                         00170800
        IF (ICOL(I).LT.1) ICOL(I)=1                                     00170900
        IF (ICOL(I).GT.3) ICOL(I)=3                                     00171000
 1725 CONTINUE                                                          00171100
C             DETERMINE MODE                                            00171200
 1726 NCOM=IZERO                                                        00171300
      IX=IZERO                                                          00171400
      DO 1727 I=1,NSURF                                                 00171500
        IF (XDISP(I).EQ.ZERO.AND.TILTX(I).EQ.ZERO) GO TO 1727           00171600
        IX=IONE                                                         00171700
        GO TO 1728                                                      00171800
 1727 CONTINUE                                                          00171900
 1728 IF ( ( (IX.EQ.IONE).OR.(HXINIT.NE.ZERO).OR.(HXDEL.NE.ZERO) )      00172000
     $     .AND. IMODE.NE.ITWO) IMODE = IONE                            00172100
C             CONVERT WAVELENGTH FROM NANOMETERS TO SYSTEM UNITS        00172200
      DEFWV(1)=632.8                                                    00172300
      DEFWV(2)=587.6                                                    00172400
      DEFWV(3)=486.1                                                    00172500
      NEND=NCOL                                                         00172600
      IF ((IPRINT/2)*2.NE.IPRINT) NEND=3                                00172700
      DO 1730 I=1,NCOL                                                  00172800
      IF ((IPRINT/2)*2.NE.IPRINT) GO TO 1729                            00172900
      WVTEMP=WAVE(ICOL(I))                                              00173000
      IWVFLG(ICOL(I))=0                                                 00173100
      IF (WAVE(ICOL(I)).EQ.0) IWVFLG(ICOL(I))=1                         00173200
      IF (WAVE(ICOL(I)).EQ.0) WVTEMP=DEFWV(ICOL(I))                     00173300
      IF (UFLAG.EQ.ONE) WAVL(ICOL(I))=WVTEMP*1.D-6                      00173400
      IF (UFLAG.EQ.TWO) WAVL(ICOL(I))=WVTEMP*1.D-7                      00173500
      IF (UFLAG.EQ.THREE) WAVL(ICOL(I))=(WVTEMP*1.D-6)/25.4D0           00173600
      GO TO 1730                                                        00173700
 1729 WVTEMP=WAVE(I)                                                    00173800
      IF (WAVE(I).EQ.0) WVTEMP=DEFWV(I)                                 00173900
      IF (UFLAG.EQ.ONE) WAVL(I)=WVTEMP*1.D-6                            00174000
      IF (UFLAG.EQ.TWO) WAVL(I)=WVTEMP*1.D-7                            00174100
      IF (UFLAG.EQ.THREE) WAVL(I)=(WVTEMP*1.D-6)/25.4D0                 00174200
 1730 CONTINUE                                                          00174300
C             CONVERT LINEAR OBJECT SIZES TO ANGLES                     00174400
 1731 IF (IFLAG.EQ.IZERO) GO TO 1732                                    00174500
      HYINIT = -DATAN(HYINIT/(S-D)) * (180.D0/PI)                       00174600
      HYDEL = -DATAN(HYDEL/(S-D)) * (180.D0/PI)                         00174700
      HXINIT = -DATAN(HXINIT/(S-D)) * (180.D0/PI)                       00174800
      HXDEL = -DATAN(HXDEL/(S-D)) * (180.D0/PI)                         00174900
      IFLAG = IZERO                                                     00175000
C 4/19/84 THE ABOVE LINE INSERTED TO CORRECT A PROBLEM WITH             00175100
C         Y OBJECT HEIGHTS;  IFLAG = 1 => H?INIT AND H?DEL              00175200
C         ARE LINEAR                                                    00175300
C         IFLAG = 0 => H?INIT AND H?DEL ARE ANGLES IN DEGREES           00175400
C                                                                       00175500
 1732 WRITE (6,40)                                                      00175600
      CALL SKEW (NFOC,LFOC,IFOC)                                        00175700
      WRITE (6,40)                                                      00175800
      GO TO 2083                                                        00175900
C                                                                       00176000
C             TURN ON MTF PRINT OPTION                                  00176100
 1740 SMAX=ARRAY(1)                                                     00176200
      IF ((((IPRINT/32)/2)*2).NE.(IPRINT/32)) GO TO 2083                00176300
      IPRINT=IPRINT+32                                                  00176400
      GO TO 2083                                                        00176500
C             TURN OFF MTF PRINT                                        00176600
 1750 SMAX=ARRAY(1)                                                     00176700
      IF ((((IPRINT/32)/2)*2).EQ.(IPRINT/32)) GO TO 2083                00176800
      IPRINT=IPRINT-32                                                  00176900
      GO TO 2083                                                        00177000
C             TURN ON MTF PLOT OPTION                                   00177100
 1760 SMAX=ARRAY(1)                                                     00177200
      IF ((((IPLTPR/8)/2)*2).NE.(IPLTPR/8)) GO TO 2083                  00177300
      IPLTPR=IPLTPR+8                                                   00177400
      GO TO 2083                                                        00177500
C              TURN OFF MTF PLOT                                        00177600
 1770 SMAX=ARRAY(1)                                                     00177700
      IF ((((IPLTPR/8)/2)*2).EQ.(IPLTPR/8)) GO TO 2083                  00177800
      IPLTPR=IPLTPR-8                                                   00177900
      GO TO 2083                                                        00178000
C                                                                       00178100
C             TURN ON RED PRINT OPTION                                  00178200
 1790 RSMAX = ARRAY(1)                                                  00178300
      IF ((((IPRINT/16)/2)*2).NE.(IPRINT/16)) GO TO 2083                00178400
      IPRINT=IPRINT+16                                                  00178500
      GO TO 2083                                                        00178600
C             TURN OFF RED PRINT                                        00178700
 1800 RSMAX=ARRAY(1)                                                    00178800
      IF ((((IPRINT/16)/2)*2).EQ.(IPRINT/16)) GO TO 2083                00178900
      IPRINT=IPRINT-16                                                  00179000
      GO TO 2083                                                        00179100
C             TURN ON RED PLOT OPTION                                   00179200
 1810 RSMAX=ARRAY(1)                                                    00179300
      IF ((((IPLTPR/4)/2)*2).NE.(IPLTPR/4)) GO TO 2083                  00179400
      IPLTPR=IPLTPR+4                                                   00179500
      GO TO 2083                                                        00179600
C             TURN OFF RED PLOT                                         00179700
 1820 RSMAX=ARRAY(1)                                                    00179800
      IF ((((IPLTPR/4)/2)*2).EQ.(IPLTPR/4)) GO TO 2083                  00179900
      IPLTPR=IPLTPR-4                                                   00180000
      GO TO 2083                                                        00180100
C                                                                       00180200
C             HERE IF "BIL" CARD                                        00180300
 1830 Y0(I)=THREE                                                       00180400
      GO TO 2083                                                        00180500
C                                                                       00180600
C             TURN ON SURFACE-BY-SURFACE PRINT OPTION                   00180700
 1850 IF ((((IPRINT/6)/2)*2).NE.(IPRINT/6)) GO TO 2083                  00180800
      IPRINT=IPRINT+6                                                   00180900
      GO TO 2083                                                        00181000
C             TURN OFF PRINT CONTROL                                    00181100
 1860 IF ((((IPRINT/6)/2)*2).EQ.(IPRINT/6)) GO TO 2083                  00181200
      IPRINT=IPRINT-6                                                   00181300
      GO TO 2083                                                        00181400
C                                                                       00181500
C             HERE IF TURNING ON LEPRT PRINT CODE                       00181600
 1880 IF (IPRINT.NE.IZERO.AND.(IPRINT/ITWO)*ITWO.NE.IPRINT) GO TO 2083  00181700
      IPRINT=IPRINT+IONE                                                00181800
      GO TO 1721                                                        00181900
C                                                                       00182000
C             HERE IF "SC" CARD                                         00182100
 1900 FACTOR=ARRAY(1)                                                   00182200
      CALL LENSCL (FACTOR)                                              00182300
      GO TO 2083                                                        00182400
C                                                                       00182500
C             HERE IF "WV" CARD                                         00182600
 1910 WAVE(1)=ARRAY(1)                                                  00182700
      WAVE(2)=ARRAY(2)                                                  00182800
      WAVE(3)=ARRAY(3)                                                  00182900
      GO TO 2083                                                        00183000
C                                                                       00183100
C             HERE IF "INSERT" CARD                                     00183200
 1920 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00183300
      GO TO 2083                                                        00183400
C                                                                       00183500
C             HERE IF "DELETE" CARD                                     00183600
 1930 CALL SURFNO (IWORD2,LEN2,ISURF,JSURF)                             00183700
      GO TO 2083                                                        00183800
C                                                                       00183900
C             HERE IF "REFS" CARD                                       00184000
 1940 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00184100
      IREF=ISURF                                                        00184200
      GO TO 2083                                                        00184300
C                                                                       00184400
C             WANT MULTIPLE SPOT PLOT                                   00184500
 1945 IALLPL=1                                                          00184600
      GO TO 1955                                                        00184700
C                                                                       00184800
C             WANT SPOT UNIT (OR RADII) PLOT                            00184900
 1950 IALLPL=0                                                          00185000
 1955 IPEN = ARRAY(1)                                                   00185100
      IF ( IPEN.LE.IZERO .OR. IPEN.GT.IFOUR ) IPEN = 1                  00185200
      CALL NEWPEN(IPEN)                                                 00185300
      IF (IPLTPR.NE.IZERO.AND.(IPLTPR/ITWO)*ITWO.NE.IPLTPR) GO TO 2083  00185400
      IPLTPR = IPLTPR + IONE                                            00185500
      GO TO 2083                                                        00185600
C             DON'T WANT SPOT UNIT (OR RADII) PLOT                      00185700
 1960 IF ( IPLTPR.NE.IZERO.AND.(IPLTPR/ITWO)*ITWO.NE.IPLTPR)            00185800
     $     IPLTPR = IPLTPR-IONE                                         00185900
      IALLPL=0                                                          00186000
      GO TO 2083                                                        00186100
C                                                                       00186200
C             DON'T WANT MULTIPLE SPOT PLOT                             00186300
 1965 IALLPL=0                                                          00186400
      GO TO 2083                                                        00186500
C                                                                       00186600
C             HERE IF "STATISTICS" CARD                                 00186700
 1970 IF (IWORD2(1).EQ.IBLANK) GO TO 1975                               00186800
      IF (IWORD2(1).EQ.ALPHA(6).AND.IWORD2(2).EQ.ALPHA(9)               00186900
     $     .AND.IWORD2(3).EQ.ALPHA(12).AND.IWORD2(4).EQ.ALPHA(5))       00187000
     $     GO TO 1980                                                   00187100
      GO TO 335                                                         00187200
 1975 FAKEA=ARRAY(1)                                                    00187300
      IPR20=IZERO                                                       00187400
      GO TO 2083                                                        00187500
 1980 FAKEA=ARRAY(1)                                                    00187600
      IPR20=IONE                                                        00187700
      GO TO 2083                                                        00187800
C             HERE IF CURVATURE SOLVE                                   00187900
 1990 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00188000
      SXNU(JSURF)=ARRAY(2)                                              00188100
      ORDN(JSURF,1)=ORDN(JSURF,1)+ONE                                   00188200
      ORDN(JSURF,2)=ORDN(JSURF,2)+ONE                                   00188300
      ORDN(JSURF,3)=ORDN(JSURF,3)+ONE                                   00188400
      GO TO 2083                                                        00188500
C             HERE IF CLEAR APERTURE SOLVE                              00188600
 2000 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00188700
      Y0(JSURF)=ARRAY(2)                                                00188800
      RDSPAC(JSURF)=ARRAY(3)                                            00188900
      ORDN(JSURF,1)=ORDN(JSURF,1)+FOUR                                  00189000
      ORDN(JSURF,2)=ORDN(JSURF,2)+FOUR                                  00189100
      ORDN(JSURF,3)=ORDN(JSURF,3)+FOUR                                  00189200
      GO TO 2083                                                        00189300
C             HERE IF THICKNESS SOLVE                                   00189400
 2010 CALL SURFNO(IWORD2,LEN2,ISURF,JSURF)                              00189500
      SXY(JSURF)=ARRAY(2)                                               00189600
      ORDN(JSURF,1)=ORDN(JSURF,1)+TWO                                   00189700
      ORDN(JSURF,2)=ORDN(JSURF,2)+TWO                                   00189800
      ORDN(JSURF,3)=ORDN(JSURF,3)+TWO                                   00189900
      GO TO 2083                                                        00190000
C             HERE IF REMOVING SOLVES                                   00190100
 2020 ORDN(JSURF,1)=ZERO                                                00190200
      ORDN(JSURF,2)=ZERO                                                00190300
      ORDN(JSURF,3)=ZERO                                                00190400
      GO TO 2083                                                        00190500
C                                                                       00190600
C             TURN ON OPTION FOR PRINTING PRIME IMAGE COORDINATES       00190700
 2040 IF ((((IPRINT/8)/2)*2).NE.(IPRINT/8)) GO TO 2083                  00190800
      IPRINT=IPRINT+8                                                   00190900
      GO TO 2083                                                        00191000
C             TURN OFF PRINT CONTROL                                    00191100
 2050 IF ((((IPRINT/8)/2)*2).EQ.(IPRINT/8)) GO TO 2083                  00191200
      IPRINT=IPRINT-8                                                   00191300
      GO TO 2083                                                        00191400
C                                                                       00191500
C             HERE IF "PRINT REF" CARD                                  00191600
C                                                                       00191700
C             TURN ON PRINT CONTROL                                     00191800
 2070 IF ((((IPRINT/2)/2)*2).NE.(IPRINT/2)) GO TO 2083                  00191900
      IPRINT=IPRINT+2                                                   00192000
      GO TO 2083                                                        00192100
C             TURN OFF PRINT CONTROL                                    00192200
 2080 IF ((((IPRINT/2)/2)*2).EQ.(IPRINT/2)) GO TO 2083                  00192300
      IPRINT=IPRINT-2                                                   00192400
 2083 CONTINUE                                                          00192500
      IF (LSL.EQ.I81) GO TO 170                                         00192600
      IENDO=LAST-LSL                                                    00192700
      DO 2085 I=1,IENDO                                                 00192800
        INPUT(I)=INPUT(I+LSL)                                           00192900
 2085 CONTINUE                                                          00193000
      IBEGDO=LAST+1                                                     00193100
      DO 2086 I=IBEGDO,80                                               00193200
        INPUT(I)=IBLANK                                                 00193300
 2086 CONTINUE                                                          00193400
      GOTO 172                                                          00193500
 2090 STOP                                                              00193600
      END                                                               00193700
C                                                                       00193800
C******************************************************                 00193900
      SUBROUTINE BESSEL(X,N,BJ,D,IER)                                   00194000
C******************************************************                 00194100
      IMPLICIT REAL*8(A-H,O-Z), INTEGER*4(I-N)                          00194200
      BJ=0.D0                                                           00194300
      IF(N.GE.0) GO TO 10                                               00194400
          IER= 1                                                        00194500
          GO TO 90                                                      00194600
   10 IF (X .GT. 0.D0) GO TO 30                                         00194700
         IF(X .LT. 0.D0) GO TO 20                                       00194800
            IER=0                                                       00194900
            BJ=1.0                                                      00195000
            GO TO 90                                                    00195100
   20    IER=2                                                          00195200
         GO TO 90                                                       00195300
C                                                                       00195400
   30 IF (X .GT. 15.D0) GO TO 40                                        00195500
         MAX= 20.D0 + 10.D0 * X - X**2 / 3.D0                           00195600
         GO TO 50                                                       00195700
   40    MAX= 90.D0 + X / 2.D0                                          00195800
C                                                                       00195900
   50 IF (N .LT. MAX) GO TO 60                                          00196000
         IER= 4                                                         00196100
         GO TO 90                                                       00196200
C                                                                       00196300
   60 IER= 0                                                            00196400
      BPREV= 0.                                                         00196500
C                                                                       00196600
C             COMPUTE STARTING VALUE OF M                               00196700
C                                                                       00196800
      MA= X + 6.D0                                                      00196900
      IF (X .GE. 5.D0) MA= 1.4D0 * X + 60.D0 / X                        00197000
      MB= N + IDINT(X) / 4 + 2                                          00197100
      MZERO= MAX0(MA, MB)                                               00197200
      DO 80 M= MZERO, MAX, 3                                            00197300
C                                                                       00197400
C             SET INITIAL VALUES FOR F(M) AND F(M-1)                    00197500
C                                                                       00197600
      FM= 0.D0                                                          00197700
      FM1= 1.0D-28                                                      00197800
      ALPHA= 0.D0                                                       00197900
      ST= -1.D0                                                         00198000
      IF (M .NE. (M / 2) * 2) ST= 1.D0                                  00198100
      M2= M - 2                                                         00198200
      DO 70 K= 1, M2                                                    00198300
      MK= M - K                                                         00198400
C                                                                       00198500
C             CALCULATE FM2 FROM RECURRENCE RELATIONSHIP                00198600
C                                                                       00198700
      FM2= 2.D0 * DFLOAT(MK) * FM1 / X - FM                             00198800
      FM= FM1                                                           00198900
      FM1= FM2                                                          00199000
      IF (MK .EQ. N + 1) BJ= FM2                                        00199100
      ST= -ST                                                           00199200
   70 ALPHA= ALPHA + FM2 * (1.D0 + ST)                                  00199300
      F0= 2.D0 * FM1 / X - FM                                           00199400
      IF (N .EQ. 0) BJ= F0                                              00199500
      ALPHA= ALPHA + F0                                                 00199600
      BJ= BJ / ALPHA                                                    00199700
      IF (DABS(BJ - BPREV) .LT. DABS(D * BJ)) GO TO 90                  00199800
   80 BPREV= BJ                                                         00199900
      IER= 3                                                            00200000
   90 RETURN                                                            00200100
      END                                                               00200200
C                                                                       00200300
C*************************************************                      00200400
      SUBROUTINE CNTCOM(NCOM,ICARD,LENGTH)                              00200500
C*************************************************                      00200600
C                                                                       00200700
C                FIND THE NUMBER OF VARIABLE VALUES ON THIS CARD BY     00200800
C                COUNTING THE NUMBER OF COMMAS OR BLANKS                00200900
C                                                                       00201000
      IMPLICIT REAL *8 (A-H,O-Z)                                        00201100
      DIMENSION ICARD(LENGTH)                                           00201200
      DATA IVAL/1H,/,IBLANK/1H /,ISLASH/1H//                            00201300
      NCOM = 0                                                          00201400
      DO 40 I=1,LENGTH                                                  00201500
      IF (ICARD(I).EQ.IBLANK) GOTO 40                                   00201600
      ISTART=I                                                          00201700
      GO TO 50                                                          00201800
  40  CONTINUE                                                          00201900
      GOTO 110                                                          00202000
  50  J0=0                                                              00202100
      DO 100 I=ISTART,LENGTH                                            00202200
        IF (ICARD(I).NE.IVAL.AND.ICARD(I).NE.IBLANK) GOTO 70            00202300
        IF (J0.EQ.0) J0=I                                               00202400
        IF (J0.EQ.I) NCOM=NCOM+1                                        00202500
        GO TO 100                                                       00202600
  70  J0=0                                                              00202700
        IF (I.EQ.LENGTH.AND.ICARD(I).NE.IBLANK.AND.ICARD(I).NE.IVAL)    00202800
     $      NCOM=NCOM + 1                                               00202900
 100  CONTINUE                                                          00203000
 110  RETURN                                                            00203100
      END                                                               00203200
C                                                                       00203300
C******************************************************                 00203400
      SUBROUTINE FINDE(STOR,ICARD,ICNT,LENGTH)                          00203500
C******************************************************                 00203600
C                                                                       00203700
C                THIS SUBR DECODES ONE FLOATING POINT NUMBER FROM       00203800
C                THE CARD IMAGE ICARD, USING ICNT NUMBER OF CHARACTERS, 00203900
C                AND PUTS THE VALUE IN STOR. ICARD IS AN INTEGER ARRAY  00204000
C                ORIGINALLY READ UNDER XXA1 FORMAT, IE ONE HOLLERITH    00204100
C                CHARACTER PER WORD.                                    00204200
C                                                                       00204300
C                INITIALIZE ALL SWITCHES                                00204400
C                SWITCH   VALUE   USE                                   00204500
C                ISSW       1     NEXT SIGN DECODED IS SIGN OF MANTISSA 00204600
C                           2     NEXT SIGN DECODED IS SIGN OF EXPONENT 00204700
C                           3     BOTH SIGNS ALREADY EXTRACTED          00204800
C                IPSW       1     DEC POINT NOT FOUND IN MANTISSA       00204900
C                           2     DEC POINT FOUND, ACCUMULATE ADJUSTMENT00205000
C                                 FACTOR DEC                            00205100
C                IESW       1     MANTISSA IS BEING EXTRACTED           00205200
C                           2     EXPONENT IS BEING EXTRACTED           00205300
C                                                                       00205400
C                IDENTIFIER USE                                         00205500
C                DEC        DECREMENT OF MANTISSA                       00205600
C                IPOS       POSITION INDEX OF INPUT IMAGE CHARACTER     00205700
C                           BEING EXAMINED                              00205800
C                VAR        VALUE OF DIGIT BEING EXTRACTED              00205900
C                TVAR       VALUE OF UNDECREMENTED MANTISSA OR EXPO-    00206000
C                           NENT NOW BEING EXTRACTED                    00206100
C                SING       =1 IF SIGN OF MANT IS + OR NOT SPECIFIED    00206200
C                           =-1 IF SIGN OF MANT IS SPECIFIED MINUS      00206300
C                ESING      AS FOR SING, SIGN ADJUSTMENT MULTIPLIER     00206400
C                           OF EXPONENT                                 00206500
C                                                                       00206600
      IMPLICIT REAL *8 (A-H,O-Z)                                        00206700
      DIMENSION ICARD(LENGTH),ILIST(17)                                 00206800
      DATA  ILIST           /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H+00206900
     $,1HE,1H-,1H.,1H,,1HD,1H /                                         00207000
      ISSW=1                                                            00207100
      DEC=1.                                                            00207200
      IPOS=1                                                            00207300
      IPSW=1                                                            00207400
      IESW=1                                                            00207500
      VAR=0.                                                            00207600
      TVAR=0.                                                           00207700
      STOR=0.                                                           00207800
      SING=1.                                                           00207900
      ESING=1.                                                          00208000
C                                                                       00208100
C                EXAMINE LIST FOR CHARACTER MATCH                       00208200
C                                                                       00208300
 10   DO 20 I=1,17                                                      00208400
        IF ( ICARD(IPOS).EQ.ILIST(I) ) GO TO 40                         00208500
 20   CONTINUE                                                          00208600
C                                                                       00208700
C                IF NO MATCH, TREAT AS ZERO                             00208800
C                                                                       00208900
 30   I=1                                                               00209000
      GO TO 50                                                          00209100
C                                                                       00209200
C                MATCH FOUND, GO TO PROPER ROUTINE                      00209300
C                                                                       00209400
 40   J=I-9                                                             00209500
      GO TO (50,80,110,80,120,130,110,130),J                            00209600
C                                                                       00209700
C                DECODE DIGIT, INCREMENT TVAR                           00209800
C                                                                       00209900
 50   VAR=I-1                                                           00210000
      TVAR=TVAR*10.+VAR                                                 00210100
C                                                                       00210200
C                IF PERIOD FOUND, INCREASE DECREMENT VARIABLE - WE      00210300
C                ARE USING BORROWED DECIMAL PLACES                      00210400
C                                                                       00210500
      IF ( IPSW.EQ.2)DEC=DEC*10.                                        00210600
C                                                                       00210700
C                IF FIRST DIGIT NOT SIGN, WE CALL MANTISSA POSITIVE     00210800
C                                                                       00210900
 60   IF ( IPOS.EQ.1 ) ISSW=2                                           00211000
C                                                                       00211100
C                INCREMENT POSITION GO TO NEXT CHAR                     00211200
C                                                                       00211300
 70   IPOS=IPOS+1                                                       00211400
      GO TO 10                                                          00211500
C                                                                       00211600
C                WE HAVE FOUND A SIGN, WHICH ONE                        00211700
C                                                                       00211800
 80   GO TO (90,100,30),ISSW                                            00211900
C                                                                       00212000
C                MANTISSA SIGN                                          00212100
C                                                                       00212200
 90   ISSW=2                                                            00212300
      SING=12-I                                                         00212400
      GO TO 70                                                          00212500
C                                                                       00212600
C                EXPONENT SIGN                                          00212700
C                                                                       00212800
 100  ISSW=3                                                            00212900
      ESING=12-I                                                        00213000
C                                                                       00213100
C                HERE IF D OR E FOUND IN IMAGE, MAKE STOR TAKE VALUE OF 00213200
C                MANTISSA, RESET TVAR, SET E SWITCH                     00213300
C                                                                       00213400
      GO TO (110,70),IESW                                               00213500
 110  STOR=SING*TVAR/DEC                                                00213600
      TVAR=0.                                                           00213700
      IESW=2                                                            00213800
      GO TO 70                                                          00213900
C                                                                       00214000
C                PERIOD SWITCH SET IF PERIOD FOUND                      00214100
C                                                                       00214200
 120  IPSW=2                                                            00214300
      GO TO 60                                                          00214400
C                                                                       00214500
C                COMMA OR BLANK FOUND, END OF DECODE                    00214600
C                                                                       00214700
 130  GO TO (140,160),IESW                                              00214800
C                                                                       00214900
C                SET STOR TO MANTISSA VALUE IF NO E FOUND               00215000
C                                                                       00215100
 140  STOR=SING*TVAR/DEC                                                00215200
 150  IF (IPOS.EQ.LENGTH) GOTO 156                                      00215300
      IPOS1=IPOS+1                                                      00215400
      DO 155 J=IPOS1,LENGTH                                             00215500
      IF (ICARD(J).EQ.ILIST(15).OR.ICARD(J).EQ.ILIST(17)) GOTO 155      00215600
      ICNT=J-1                                                          00215700
      GOTO 156                                                          00215800
 155  CONTINUE                                                          00215900
      ICNT=J-1                                                          00216000
 156  CONTINUE                                                          00216100
      RETURN                                                            00216200
C                                                                       00216300
C                IF E FOUND, STOR IS ALREADY VALUE OF MANTISSA          00216400
C                                                                       00216500
 160  IPOW=TVAR*ESING                                                   00216600
      STOR=STOR*(10.D0**IPOW)                                           00216700
      GO TO 150                                                         00216800
      END                                                               00216900
C                                                                       00217000
C****************************************************                   00217100
      SUBROUTINE FINRAY(NFOC)                                           00217200
C****************************************************                   00217300
C      6-1-81 VERSION                                                   00217400
      IMPLICIT REAL*8(A-H,O-Z)                                          00217500
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00217600
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00217700
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00217800
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00217900
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00218000
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00218100
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00218200
     $                FREF(40),FREF0,WAVL(3)                            00218300
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00218400
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00218500
     $                IPR20,IREF,IJK,IALLPL                             00218600
C                                                                       00218700
       DESX=0                                                           00218800
       DESY=0                                                           00218900
       N=0                                                              00219000
       IFLAG=0                                                          00219100
       Z=0.0                                                            00219200
       PI=3.141592653589793D0                                           00219300
       TEMP = S-D                                                       00219400
       HYMAX = HYINIT + (RNOBJ-1.)*HYDEL                                00219500
       HYMAX = -DTAN( HYMAX*PI/180. ) * TEMP                            00219600
       HXMAX = HXINIT + (RNOBJ-1.)*HXDEL                                00219700
       HXMAX = -DTAN( HXMAX*PI/180. ) * TEMP                            00219800
       AY=DMAX1(DABS(HYMAX),DABS(HYINIT))                               00219900
       AX=DMAX1(DABS(HXMAX),DABS(HXINIT))                               00220000
       RHONEW=RHO+DSQRT(AX*AX+AY*AY)                                    00220100
       A=RHONEW/TEMP                                                    00220200
       THISHY = -DTAN( HYINIT*PI/180. ) * TEMP                          00220300
       THISHX = -DTAN( HXINIT*PI/180. ) * TEMP                          00220400
       OBJNUM = 1.0                                                     00220500
       IF (NFOC.EQ.0) GO TO 5                                           00220600
       THISHY = HYINIT + (NFOC-1)*HYDEL                                 00220700
       THISHX = HXINIT + (NFOC-1)*HXDEL                                 00220800
       THISHY = -DTAN( THISHY*PI/180. ) * TEMP                          00220900
       THISHX = -DTAN( THISHX*PI/180. ) * TEMP                          00221000
  5    OMEGA=DSQRT((2.*PI/CLTRA(1))*(1.-1./DSQRT(1.+A*A)))              00221100
       BETA=OMEGA/2.                                                    00221200
       ALPHA=BETA                                                       00221300
       ALPHAN=ALPHA                                                     00221400
 10    CSALPH=DCOS(ALPHA)                                               00221500
       P=DSIN(BETA)/CSALPH                                              00221600
       IF( DABS(P).GE.1.0D0) GO TO 20                                   00221700
       THETA = DARSIN(P)                                                00221800
       COSGAM=CSALPH*DCOS(THETA)                                        00221900
       TANGAM=DSQRT((1./COSGAM**2)-1.)                                  00222000
       IF( TANGAM.GT.DABS(A) ) GO TO 20                                 00222100
       N=N+1                                                            00222200
       QX=DSIN(BETA)                                                    00222300
       QY=DSIN(ALPHA)                                                   00222400
       QZ=COSGAM                                                        00222500
       TEMP1 = (S-D)/QZ                                                 00222600
       X=TEMP1*QX + THISHX                                              00222700
       Y=TEMP1*QY + THISHY                                              00222800
       WRITE(40)X,Y,Z,QX,QY,QZ,THISHY,THISHX,DESX,DESY                  00222900
       QYM=-QY                                                          00223000
       YM=TEMP1*QYM + THISHY                                            00223100
       WRITE(40)X,YM,Z,QX,QYM,QZ,THISHY,THISHX,DESX,DESY                00223200
       IF(IMODE.NE.1) GO TO 15                                          00223300
       QXM=-QX                                                          00223400
       XM=TEMP1*QXM + THISHX                                            00223500
       WRITE(40)XM,YM,Z,QXM,QYM,QZ,THISHY,THISHX,DESX,DESY              00223600
       WRITE(40)XM,Y,Z,QXM,QY,QZ,THISHY,THISHX,DESX,DESY                00223700
 15    IFLAG=0                                                          00223800
       ALPHA=ALPHA+OMEGA                                                00223900
       GO TO 10                                                         00224000
 20    IF(IFLAG.EQ.1) GO TO 25                                          00224100
       BETA=BETA+OMEGA                                                  00224200
       ALPHA=ALPHAN                                                     00224300
       IFLAG=1                                                          00224400
       GO TO 10                                                         00224500
 25    CONTINUE                                                         00224600
       IF(NFOC.NE.0) GO TO 30                                           00224700
       THISHY = HYINIT + OBJNUM*HYDEL                                   00224800
       THISHX = HXINIT + OBJNUM*HXDEL                                   00224900
       THISHY = -DTAN( THISHY*PI/180. ) * TEMP                          00225000
       THISHX = -DTAN( THISHX*PI/180. ) * TEMP                          00225100
       OBJNUM = OBJNUM + 1.0                                            00225200
       IF ( OBJNUM.GT.RNOBJ ) GO TO 30                                  00225300
       GO TO 5                                                          00225400
 30    RETURN                                                           00225500
       END                                                              00225600
C                                                                       00225700
C*****************************************************                  00225800
      SUBROUTINE FLOTIN(IND,ICARD,BUFR,LENGTH)                          00225900
C*****************************************************                  00226000
C                                                                       00226100
C                DECODE A STRING OF VARIABLES FROM CARD IMAGE           00226200
C                INTO ONE CONTIGUOUS ARRAY                              00226300
C                                                                       00226400
      IMPLICIT REAL *8 (A-H,O-Z)                                        00226500
      DIMENSION ICARD(LENGTH),BUFR(LENGTH)                              00226600
      CALL CNTCOM(NCOM,ICARD,LENGTH)                                    00226700
      CALL FREARA(NCOM,ICARD,BUFR(IND+1),LENGTH)                        00226800
      RETURN                                                            00226900
      END                                                               00227000
C                                                                       00227100
C*****************************************************                  00227200
      SUBROUTINE FOCUS(ZF,BLOB,N,FID)                                   00227300
C*****************************************************                  00227400
      IMPLICIT REAL *8 (A-H,O-Z)                                        00227500
C                                                                       00227600
C             FOCUS DETERMINES IMAGE DISTANCE FOR MINIMUM SPOT SIZE     00227700
C                                                                       00227800
      DIMENSION ZF(10),BLOB(10)                                         00227900
      A1=(BLOB(1)-BLOB(2))/(ZF(1)-ZF(2))                                00228000
      N1=N-1                                                            00228100
      A2=(BLOB(N1)-BLOB(N))/(ZF(N1)-ZF(N))                              00228200
      B1=BLOB(2)-A1*ZF(2)                                               00228300
      B2=BLOB(N)-A2*ZF(N)                                               00228400
      FID=(B2-B1)/(A1-A2)                                               00228500
      RETURN                                                            00228600
      END                                                               00228700
C                                                                       00228800
C*****************************************************                  00228900
      SUBROUTINE FREARA(NCOM,ICARD,BUFR,LENGTH)                         00229000
C*****************************************************                  00229100
C                                                                       00229200
C             FREE FORM FLOATING POINT ARRAY INPUT                      00229300
C                                                                       00229400
C             CALLING SEQUENCE                                          00229500
C             VARIABLE  USE                                             00229600
C                                                                       00229700
C             NCOM      NUMBER OF VALUES ON CARD IMAGE                  00229800
C             ICARD     FWA OF CARD IMAGE                               00229900
C             BUFR      FWA OF ARRAY INTO WHICH TO DECODE               00230000
C                                                                       00230100
      IMPLICIT REAL *8 (A-H,O-Z)                                        00230200
      DIMENSION ICARD(LENGTH),BUFR(LENGTH)                              00230300
      IND=1                                                             00230400
      INDB=1                                                            00230500
      IF(NCOM.EQ.0)RETURN                                               00230600
      DO 10 I=1,NCOM                                                    00230700
C             CALL FINDE TO DECODE ONE FLOATING POINT NUMBER            00230800
        CALL FINDE(BUFR(INDB),ICARD(IND),ICNT,LENGTH)                   00230900
        INDB=INDB+1                                                     00231000
        IND=IND+ICNT                                                    00231100
   10 CONTINUE                                                          00231200
      RETURN                                                            00231300
      END                                                               00231400
C                                                                       00231500
C*******************************************************                00231600
      SUBROUTINE HEADIN(LAMDX)                                          00231700
C*******************************************************                00231800
C                                                                       00231900
C             HEADIN CALLED WITH COLOR NUMBER                           00232000
C                                                                       00232100
      IMPLICIT REAL *8 (A-H,O-Z)                                        00232200
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00232300
 10   FORMAT(//' SYSTEM NO. ',I3,7X,'GENOPTICS - A GENERAL OPTICAL',    00232400
     $      ' SYSTEMS EVALUATION PROGRAM')                              00232500
 20   FORMAT(13X,80A1)                                                  00232600
 30   FORMAT('       COLOR',I3)                                         00232700
 40   FORMAT(1H )                                                       00232800
      WRITE(6,10) NSYS                                                  00232900
C                                                                       00233000
C             IF LAMDX IS ZERO, PRINT NO COLOR NUMBER                   00233100
C                                                                       00233200
      IF ( LAMDX ) 60,70,50                                             00233300
 50   WRITE(6,30) LAMDX                                                 00233400
      GO TO 70                                                          00233500
 60   WRITE(6,30) LAMDA                                                 00233600
 70   WRITE(6,20) NAME                                                  00233700
 80   WRITE(6,40)                                                       00233800
      RETURN                                                            00233900
      END                                                               00234000
C                                                                       00234100
C*****************************************************                  00234200
      SUBROUTINE LENSCL(FACTOR)                                         00234300
C*****************************************************                  00234400
C                                                                       00234500
C               THIS ROUTINE ADDED 9-12-80                              00234600
C               IT SCALES A PREVIOUSLY DEFINED LENS SYSTEM              00234700
C               BY AN AMOUNT "FACTOR"; ONLY FIRST ORDER                 00234800
C               PROPERTIES ARE AFFECTED.                                00234900
C                                                                       00235000
      IMPLICIT REAL *8 (A-H,O-Z)                                        00235100
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00235200
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00235300
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00235400
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00235500
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00235600
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00235700
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00235800
     $                FREF(40),FREF0,WAVL(3)                            00235900
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00236000
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00236100
     $                IPR20,IREF,IJK,IALLPL                             00236200
C                                                                       00236300
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00236400
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00236500
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00236600
      EQUIVALENCE (TRASH(10),FBNU)                                      00236700
C                                                                       00236800
      DATA ZERO/0.D0/                                                   00236900
C                                                                       00237000
      DIMENSION FACT(4)                                                 00237100
C             IF FACTOR LE 0, PRINT ERROR MESSAGE AND RETURN            00237200
      IF ( FACTOR.LE.ZERO ) GO TO 30                                    00237300
C               FACTOR IS VALID, PERFORM THE SCALING                    00237400
      DO 4 I=1,40                                                       00237500
        IF (FN(I,1).EQ.ZERO) GO TO 8                                    00237600
  4   CONTINUE                                                          00237700
  8   NUMSRF = I-1                                                      00237800
      IF (NUMSRF.EQ.0) GO TO 50                                         00237900
      DO 20 I=1,NUMSRF                                                  00238000
C               SCALE BASIC SURFACE PARAMETERS                          00238100
         T(I)      = T(I)*FACTOR                                        00238200
         R(I)      = R(I)*FACTOR                                        00238300
         C(I)      = C(I)/FACTOR                                        00238400
         RX(I)     = RX(I)*FACTOR                                       00238500
         CX(I)     = CX(I)/FACTOR                                       00238600
C               DISPLACEMENTS ARE SCALED, TILTS ARE NOT                 00238700
         XDISP(I)  = XDISP(I)*FACTOR                                    00238800
         YDISP(I)  = YDISP(I)*FACTOR                                    00238900
C               GRATING SPACING IS SCALED                               00239000
         RDSPAC(I) = RDSPAC(I)/FACTOR                                   00239100
C               ACONIC COEFFICIENTS ARE SCALED ACCORDING TO POWERS      00239200
         FACTSQ    = FACTOR*FACTOR                                      00239300
         FACT(1)   = FACTSQ*FACTOR                                      00239400
         FACT(2)   = FACTSQ*FACT(1)                                     00239500
         FACT(3)   = FACTSQ*FACT(2)                                     00239600
         FACT(4)   = FACTSQ*FACT(3)                                     00239700
         DO 10 J=1,4                                                    00239800
            COEF(I,J) = COEF(I,J)/FACT(J)                               00239900
 10      CONTINUE                                                       00240000
C               MASK PARAMETERS ARE SCALED                              00240100
         FMASK(I)  = FMASK(I)*FACTOR                                    00240200
         IF( FAKEC(I).EQ.0.D0 )GO TO 20                                 00240300
         FMASK(I)  = FMASK(I)/FACTOR                                    00240400
         XMN(I)    = XMN(I)*FACTOR                                      00240500
         XMX(I)    = XMX(I)*FACTOR                                      00240600
         YMN(I)    = YMN(I)*FACTOR                                      00240700
         YMX(I)    = YMX(I)*FACTOR                                      00240800
 20   CONTINUE                                                          00240900
      XSMIN  = XSMIN*FACTOR                                             00241000
      XSMAX  = XSMAX*FACTOR                                             00241100
      YSMIN  = YSMIN*FACTOR                                             00241200
      YSMAX  = YSMAX*FACTOR                                             00241300
      IF (UFLAG.EQ.1.0 .AND. FACTOR.EQ. .1D0 ) UFLAG=2                  00241400
      IF (UFLAG.EQ.1.0 .AND. FACTOR.EQ. .03937007874D0 ) UFLAG=3        00241500
      IF (UFLAG.EQ.2.0 .AND. FACTOR.EQ. 10.D0 ) UFLAG=1                 00241600
      IF (UFLAG.EQ.2.0 .AND. FACTOR.EQ. .3937007874D0 ) UFLAG=3         00241700
      IF (UFLAG.EQ.3.0 .AND. FACTOR.EQ. 25.4D0 ) UFLAG=1                00241800
      IF (UFLAG.EQ.3.0 .AND. FACTOR.EQ. 2.54D0 ) UFLAG=2                00241900
C                                                                       00242000
      FXYJ   = FXYJ*FACTOR                                              00242100
      D      = D*FACTOR                                                 00242200
      RHO    = RHO*FACTOR                                               00242300
      FOCL   = FOCL*FACTOR                                              00242400
      DO 25 I=1,3                                                       00242500
      WAVL(I) = WAVL(I)*FACTOR                                          00242600
 25   CONTINUE                                                          00242700
      GO TO 50                                                          00242800
C             PRINT ERROR MESSAGE(FOR BAD SCALE FACTOR)                 00242900
 30   WRITE(6,40) FACTOR                                                00243000
 40   FORMAT(1X,10X,'BAD SCALE FACTOR GIVEN ( ',1PE15.7,' ) ; ',        00243100
     $       'NO SCALING PERFORMED'/)                                   00243200
C               FINISHED SCALING, RETURN TO MAIN PROGRAM                00243300
 50   RETURN                                                            00243400
      END                                                               00243500
C                                                                       00243600
C********************************************************               00243700
      SUBROUTINE MAVEC(PRODA,MULT)                                      00243800
C********************************************************               00243900
C                                                                       00244000
C                 MAVEC PERFORMS MATRIX*VECTOR AND                      00244100
C                VECTOR*MATRIX MULTIPLICATION                           00244200
C                                                                       00244300
      IMPLICIT REAL *8 (A-H,O-Z)                                        00244400
      COMMON /ROT/ ROTA(9)                                              00244500
      DIMENSION PRODA(3)                                                00244600
      DIMENSION PROD(3)                                                 00244700
      REAL *8 MULT(3)                                                   00244800
      IEN=7                                                             00244900
      INC=3                                                             00245000
      JNC=1                                                             00245100
      GO TO 10                                                          00245200
      ENTRY VECMA(PRODA,MULT)                                           00245300
      IEN=3                                                             00245400
      JNC=3                                                             00245500
      INC=1                                                             00245600
 10   IST=1                                                             00245700
      DO 30 INT=1,3                                                     00245800
        PROD(INT)=0.                                                    00245900
        DO 20 I=IST,IEN,INC                                             00246000
          JNT=3-(IEN-I)/INC                                             00246100
          PROD(INT)=PROD(INT)+MULT(JNT)*ROTA(I)                         00246200
 20     CONTINUE                                                        00246300
        IST=IST+JNC                                                     00246400
        IEN=IEN+JNC                                                     00246500
 30   CONTINUE                                                          00246600
      DO 40 I=1,3                                                       00246700
 40   PRODA(I)=PROD(I)                                                  00246800
      RETURN                                                            00246900
      END                                                               00247000
C                                                                       00247100
C********************************************************               00247200
      SUBROUTINE PARAX                                                  00247300
C********************************************************               00247400
C                                                                       00247500
C     PURPOSE                                                           00247600
C            PARAXIAL RAY TRACING SUBROUTINE                            00247700
C                                                                       00247800
C     LAST UPDATE 4/10/84 BY JOHN PARKER (LINE 321 OF PARAX)            00247900
C                                                                       00248000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC              00248100
C                                                                       00248200
      IMPLICIT REAL *8 (A-H,O-Z)                                        00248300
C                                                                       00248400
C                                                                       00248500
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00248600
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00248700
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00248800
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00248900
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00249000
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00249100
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00249200
     $                FREF(40),FREF0,WAVL(3)                            00249300
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00249400
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00249500
     $                IPR20,IREF,IJK,IALLPL                             00249600
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00249700
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00249800
      COMMON /ABCODE/ ISURFX,ISURXN,RSAVE,TM3,DUM(40),RR(40),RCON(40)   00249900
      DIMENSION RNU(40),B(40),U(40),BU(40),F(40),CC(40),E(40),P(40)     00250000
      DIMENSION ACH(40),BCH(40),BAS(40),FAS(40),CAS(40),EAS(40)         00250100
      DIMENSION X(40),BY(40),XY(40)                                     00250200
C                                                                       00250300
      DATA EPS/1.D-9/,ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/                    00250400
C                                                                       00250500
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00250600
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00250700
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00250800
      EQUIVALENCE (TRASH(10),FBNU)                                      00250900
      EQUIVALENCE (RNU(1),CAS(1))                                       00251000
C                                                                       00251100
   10 FORMAT (/10X,10HINPUT RAYS,                                       00251200
     $       //13X,2HY=,1PE13.6,2X,2HU=,1PE13.6,                        00251300
     $       2X,3HCY=,1PE13.6,2X,3HCU=,1PE13.6,2X,                      00251400
     $       14HTARGET HEIGHT=,1PE13.6)                                 00251500
   30 FORMAT (//T3,7HSURFACE,T15,7HAXIAL Y,T33,7HAXIAL U,T51,7HCHIEF Y, 00251600
     $       T69,7HCHIEF U,/)                                           00251700
   40 FORMAT (T6,I2,T10,1PE16.8,T28,1PE16.8,T46,1PE16.8,T64,1PE16.8)    00251800
   60 FORMAT (/13X,25HIMAGE DISTANCE AXIAL RAY=,1PE16.8,6X,             00251900
     $       15HMAGNIFICATION= ,1PE16.8,/13X,                           00252000
     $       25HIMAGE DISTANCE CHIEF RAY=,1PE16.8,6X,                   00252100
     $       14HFOCAL LENGTH =,1PE17.8,6X,10HF NUMBER =,1PE16.8//)      00252200
   70 FORMAT (25H ABERRATIONS    SPHERICAL,9X,4HCOMA,10X,11HASTIGMATISM,00252300
     $       5X,10HDISTORTION,7X,7HPETZVAL,15X,9HCHROMATIC/8H SURFACE,  00252400
     $       89X,7HA COEF ,9X,7HB COEF )                                00252500
   80 FORMAT(4X,I2,6X,1P7E16.8)                                         00252600
   90 FORMAT(10X,'APERTURE STOP SURFACE MUST BE GREATER THAN 1; = ',I2/)00252700
  100 FORMAT(4X,I2,4H ASP,2X,1P4E16.8)                                  00252800
  110 FORMAT (/9H TOTAL SP,3X,1P7E16.8)                                 00252900
  120 FORMAT (10H TOTAL ASP,2X,1P4E16.8)                                00253000
  130 FORMAT (6H TOTAL,6X,1P7E16.8)                                     00253100
  140 FORMAT (/13X,39HVECTOR SUM OF THIRD ORDER ABERRATIONS =,1PE16.8)  00253200
  150 FORMAT (/13X,39HVECTOR SUM OF FIRST ORDER ABERRATIONS =,1PE16.8/) 00253300
  170 FORMAT (//32H CONIC CONSTANT OF PRIMARY   =  ,1PE16.9)            00253400
  180 FORMAT (32H CONIC CONSTANT OF SECONDARY =  ,1PE16.9///)           00253500
  220 FORMAT (18H FOCAL POINTS AT  ,1PE16.9,9H AND AT  ,1PE16.9/)       00253600
  230 FORMAT (/13X,8HSURFACE ,I2,18H IS A TORIC.RX(I)=,1PE16.8)         00253700
  240 FORMAT (/13X,8HSURFACE ,I2,33H IS A CYLINDER WITH AXIS ALONG X.,  00253800
     $       6HR(I)= ,1PE16.8)                                          00253900
  250 FORMAT (/13X,8HSURFACE ,I2,33H IS A CYLINDER WITH AXIS ALONG Y.,  00254000
     $       7HRX(I)= ,1PE16.8)                                         00254100
  260 FORMAT(10X,'APERTURE STOP SIZE NOT SPECIFIED, WILL NOT LOCATE ',  00254200
     $       'PARAXIAL PUPILS'/)                                        00254300
  270 FORMAT(10X,'FOUND TILTED/DECENTERED SURFACE WHILE ',              00254400
     $       'LOCATING PUPILS'/)                                        00254500
  271 FORMAT(10X,'T(',I2,') = ',1PE16.8,' FROM THICKNESS SOLVE'/)       00254600
  272 FORMAT(10X,'T(',I2,') = ',1PE16.8,' FROM CLEAR APERTURE SOLVE'/)  00254700
  273 FORMAT(10X,'C(',I2,') = ',1PE16.8,' FROM CURVATURE SOLVE'/)       00254800
C                                                                       00254900
      KK=0                                                              00255000
      HYMAX=HYINIT+(RNOBJ-1.)*HYDEL                                     00255100
      HYMAX=-DTAN(HYMAX*3.14159265358979D0/180.)*(S-D)                  00255200
      HINIT=-DTAN(HYINIT*3.14159265358979D0/180.)*(S-D)                 00255300
      IF ( DABS(HINIT).GT.DABS(HYMAX) ) HYMAX = HINIT                   00255400
C                                                                       00255500
C                BEGIN CALCULATING POSITION OF EP                       00255600
C                I = SURF NUMBER OF APERTURE STOP                       00255700
C                                                                       00255800
      I=APSTOP/30                                                       00255900
C                                                                       00256000
C                NONE SPECIFIED                                         00256100
C                                                                       00256200
      IF (I.LE.1.AND.(IPRINT/2)*2.EQ.IPRINT) WRITE(6,90) I              00256300
      IF (I.LE.1) RETURN                                                00256400
      J=I                                                               00256500
      ISTOP=J                                                           00256600
      KK=I                                                              00256700
      ISW=1                                                             00256800
      L=J-1                                                             00256900
      LAMDA = 2                                                         00257000
      IF ( NCOL.EQ.1 ) LAMDA = ICOL(1)                                  00257100
      IF ( (DABS(FXY)+DABS(FXNU)+DABS(FBY)+DABS(FBNU)) .EQ. ZERO )      00257200
     $   GO TO 275                                                      00257300
      FXNU=RHO/(S-D)                                                    00257400
      FXY=FXNU*(S-D)                                                    00257500
      FBY=ZERO                                                          00257600
      FBNU = -HYMAX/(S-D)                                               00257700
  275 XY(1)=FXY                                                         00257800
      U(1)=FXNU                                                         00257900
      BY(1)=FBY                                                         00258000
      BU(1)=FBNU                                                        00258100
      GO TO 370                                                         00258200
C                  TRACE UP TO APERTURE STOP IN CASE THERE ARE          00258300
C                  CURVATURE/THICKNESS SOLVES TO BE DETERMINED          00258400
C                FIND SIZE AND LOCATION OF ENTRANCE PUPIL               00258500
  280 IF ( FMASK(ISTOP).GT.ZERO ) GO TO 290                             00258600
      IF ((IPRINT/2)*2.EQ.IPRINT) WRITE(6,260)                          00258700
      GO TO 682                                                         00258800
  290 AB=ZERO                                                           00258900
      ABB=FMASK(ISTOP)                                                  00259000
      SGN1 = FREF0                                                      00259100
      L = ISTOP-1                                                       00259200
      DO 295 I=1,L                                                      00259300
        IF (FREF(I).EQ.-ONE) SGN1 = -SGN1                               00259400
  295 CONTINUE                                                          00259500
      SGNAP = SGN1*FREF(ISTOP)                                          00259600
      IF (ISTOP.EQ.2) GO TO 300                                         00259700
      L=ISTOP-2                                                         00259800
      TM1=.1D0                                                          00259900
      TM1B=TM1                                                          00260000
      GO TO 310                                                         00260100
  300 TM1=.1D0                                                          00260200
      TM1B=TM1                                                          00260300
      SGN1 = FREF0                                                      00260400
      IF (FREF(1).EQ.-ONE) SGN1 = -SGN1                                 00260500
      GO TO 330                                                         00260600
  310 DO 320 I=1,L                                                      00260700
        M=ISTOP-I                                                       00260800
        IF ((IPRINT/2)*2.NE.IPRINT) GO TO 315                           00260900
        IF (TILTX(I).NE.ZERO .OR. TILTY(I).NE.ZERO .OR. TILTZ(I).NE.ZERO00261000
     $     .OR. XDISP(I).NE.ZERO .OR. YDISP(I).NE.ZERO ) WRITE(6,270)   00261100
  315   SGN2 = SGN1                                                     00261200
        IF (FREF(M).EQ.-ONE) SGN2 = -SGN1                               00261300
        RN1  = FN(M-1,LAMDA)*SGN2                                       00261400
        RN2  = FN(M,LAMDA)*SGN1                                         00261500
        GNU  = RN2/RN1                                                  00261600
        ABB  = ABB + T(M)*TM1B                                          00261700
        AB   = AB + T(M)*TM1                                            00261800
        TM1B = GNU*TM1B + ABB*C(M)*(ONE-GNU)                            00261900
        TM1  = GNU*TM1 + AB*C(M)*(ONE-GNU)                              00262000
        SGN1 = SGN2                                                     00262100
  320 CONTINUE                                                          00262200
  330 TM7=-AB/TM1                                                       00262300
      RHO=DABS(ABB+TM7*TM1B)                                            00262400
      T(1)=TM7                                                          00262500
      D = ZERO                                                          00262600
      ENPUPR = RHO                                                      00262700
      ENPUPL = D                                                        00262800
      FXY=RHO                                                           00262900
      FXNU=RHO/(S-D)                                                    00263000
      FBY=ZERO                                                          00263100
      FBNU = -HYMAX/(S-D)                                               00263200
C                                                                       00263300
C             LOCATE AND SIZE PARAXIAL EXIT PUPIL; PRINT INFORMATION    00263400
      AB=ZERO                                                           00263500
      ABB=FMASK(ISTOP)                                                  00263600
      L=ISTOP+1                                                         00263700
      SGN1 = SGNAP                                                      00263800
      TM1=.1D0                                                          00263900
      TM1B=TM1                                                          00264000
      DO 340 I=L,NSURF                                                  00264100
        IF ((IPRINT/2)*2.NE.IPRINT) GO TO 335                           00264200
        IF (TILTX(I).NE.ZERO .OR. TILTY(I).NE.ZERO .OR. TILTZ(I).NE.ZERO00264300
     $      .OR. XDISP(I).NE.ZERO .OR. YDISP(I).NE.ZERO ) WRITE(6,270)  00264400
 335    SGN2 = SGN1                                                     00264500
        IF (FREF(I).EQ.-ONE) SGN2 = -SGN1                               00264600
        RN1  = FN(I,LAMDA)*SGN2                                         00264700
        RN2  = FN(I-1,LAMDA)*SGN1                                       00264800
        GNU  = RN2/RN1                                                  00264900
        ABB  = ABB + T(I-1)*TM1B                                        00265000
        AB   = AB + T(I-1)*TM1                                          00265100
        TM1B = GNU*TM1B + ABB*C(I)*(GNU-ONE)                            00265200
        TM1  = GNU*TM1 + AB*C(I)*(GNU-ONE)                              00265300
        SGN1 = SGN2                                                     00265400
  340 CONTINUE                                                          00265500
      TM7=-AB/TM1                                                       00265600
      TM8=DABS(ABB+TM7*TM1B)                                            00265700
      EXPUPR = TM8                                                      00265800
      EXPUPL = TM7                                                      00265900
C                END OF EXIT PUPIL LOCATION                             00266000
C                                                                       00266100
C             IF FOLLOWING 'LEPRT' COMMAND, RETURN TO MAIN ROUTINE      00266200
C                                                                       00266300
  350 IF ((IPRINT/2)*2.EQ.IPRINT) GO TO 355                             00266400
      CALL PREPRT                                                       00266500
      RETURN                                                            00266600
C                                                                       00266700
C                                                                       00266800
C             SET SURFACE PRINT SWITCH                                  00266900
C                                                                       00267000
  355 IPRINA=0                                                          00267100
      IPRINB=0                                                          00267200
      IF ((IPRINT/4)*2.NE.IPRINT/2) IPRINA=1                            00267300
      LAMDA=ICOL(1)                                                     00267400
C                                                                       00267500
      ISW=2                                                             00267600
C                                                                       00267700
C                TRACE NSURF NUMBER OF SURFACES FOR NCOL COLORS         00267800
C                                                                       00267900
C                                                                       00268000
C        COLORS LOOP - ENTER                                            00268100
C                                                                       00268200
  360 DO 680 K=1,NCOL                                                   00268300
        L=NSURF                                                         00268400
        XY(1)=FXY                                                       00268500
        BY(1)=FBY                                                       00268600
        U(1)=FXNU                                                       00268700
        BU(1) = FBNU                                                    00268800
C             SET COLOR NUMBER                                          00268900
        LAMDA=ICOL(K)                                                   00269000
C                                                                       00269100
C             SGN1, SGN2 ARE USED TO DETERMINE SIGNS OF INDICES         00269200
  370   SGN1=FREF0                                                      00269300
C             START OF SURFACE-BY-SURFACE PARAXIAL RAY TRACE            00269400
        DO 450 I=1,L                                                    00269500
          SGN2 = SGN1                                                   00269600
          IF (FREF(I).EQ.-ONE) SGN2 = -SGN1                             00269700
          TM1 = SGN2*FN(I,LAMDA)                                        00269800
          IF (I.EQ.1) TM2 = SGN1*OBJN(LAMDA)                            00269900
          IF (I.GT.1) TM2 = SGN1*FN(I-1,LAMDA)                          00270000
          TM3 = C(I)                                                    00270100
          GNU = TM2/TM1                                                 00270200
          IORDN=ORDN(I,LAMDA)+.5                                        00270300
          IORDA=0                                                       00270400
C                                                                       00270500
          IF (I.EQ.1) TM1A = TM1                                        00270600
          IF (I.EQ.2) TM1B = TM1                                        00270700
          IF (I.EQ.3) TM1C = TM1                                        00270800
          IF (I.EQ.2) GNU2 = GNU                                        00270900
          IF (I.EQ.3) GNU3 = GNU                                        00271000
C                IF NORDN(I) AND 1, GO TO CURVATURE SOLVE               00271100
C                                                                       00271200
  390     IF ((IORDN/2)*2.NE.IORDN) GO TO 400                           00271300
          CALL SURTYP (I)                                               00271400
          X(I)=TM3*(GNU-ONE)                                            00271500
C                                                                       00271600
C                U IS ANGLE OF AXIAL RAY                                00271700
C                                                                       00271800
          U(I+1) = GNU*U(I) + XY(I)*X(I)                                00271900
          GO TO 410                                                     00272000
C                                                                       00272100
C                CURVATURE SOLVE ROUTINE                                00272200
C                                                                       00272300
C                THE USER SPECIFIES THE ANGLE AT WHICH THE RAY LEAVES   00272400
C                THE SURFACE (SXNU), AND THE NECESSARY CURVATURE        00272500
C                OF THE SURFACE (C(I)) IS CALCULATED                    00272600
C                                                                       00272700
  400     C(I)=(SXNU(I+1)-GNU*U(I))/(XY(I)*(GNU-ONE))                   00272800
          IF ((IPRINT/2)*2.EQ.IPRINT) WRITE(6,273) I,C(I)               00272900
          TM3=C(I)                                                      00273000
          X(I)=TM3*(GNU-ONE)                                            00273100
          R(I)=1./C(I)                                                  00273200
          CALL SURTYP (I)                                               00273300
          U(I+1) = GNU*U(I) + XY(I)*X(I)                                00273400
C                                                                       00273500
C                IF AND(NORDN(I),2), GO TO THICKNESS SOLVE ROUTINE      00273600
C                                                                       00273700
  410     IF ((IORDN/4)*2.EQ.IORDN/2) GO TO 420                         00273800
C                                                                       00273900
C                THICKNESS SOLVE (OR HEIGHT SOLVE) ROUTINE              00274000
C                THE USER SPECIFIES THE HEIGHT OF THE RAY ON THE NEXT   00274100
C                SURFACE (SXY(I+1)),CALCULATE THE THICKNESS-- DIST      00274200
C                FROM SURFACE I TO SURFACE I+1 (T(I))                   00274300
C                                                                       00274400
          T(I) = (SXY(I+1)-XY(I))/U(I+1)                                00274500
          IF ((IPRINT/2)*2.EQ.IPRINT) WRITE(6,271) I,T(I)               00274600
          IORDA=1                                                       00274700
C                                                                       00274800
C                IF AND(NORDN(I),4) GO TO CLEAR APERTURE ROUTINE        00274900
C                                                                       00275000
  420     IF ((IORDN/8)*2.EQ.IORDN/4) GO TO 430                         00275100
C                                                                       00275200
C                CLEAR APERTURE ROUTINE                                 00275300
C                THE USER SPECIFIES Y SUB ZERO AND THE TO-THE-EDGE      00275400
C                THICKNESS, CALCULATE T(I)                              00275500
C                THAT IS, ADD THE DIFFERENCE OF SAG AT SURF I AND       00275600
C                SAG AT I+1 (AT REFERENCE HEIGHT Y0) TO THE MINIMUM     00275700
C                CLEAR APERTURE SPECIFIED BY USER - THIS MEANS THAT     00275800
C                THE DIST BETWEEN SURF I AND I+1 IS A MINIMUM OF        00275900
C                RDSPAC(I) FROM HEIGHT ZERO (VERTICES) THRU Y SUB ZERO  00276000
C                                                                       00276100
          ZA=C(I)*Y0(I)*Y0(I)/(1.+DSQRT(1.-C(I)*C(I)*Y0(I)*Y0(I)))      00276200
          ZB=C(I+1)*Y0(I)*Y0(I)/(1.+DSQRT(1.-C(I+1)*C(I+1)*Y0(I)*Y0(I)))00276300
          T(I)=RDSPAC(I)                                                00276400
          IF (ZA.GE.ZB) T(I)=T(I)+ZA-ZB                                 00276500
          IF ((IPRINT/2)*2.EQ.IPRINT) WRITE(6,272) I,T(I)               00276600
C                                                                       00276700
C                CALCULATE HEIGHT OF AXIAL RAY, XY                      00276800
C                                                                       00276900
  430     XY(I+1) = XY(I) + U(I+1)*T(I)                                 00277000
C                                                                       00277100
C                CALCULATE ANGLE OF CHIEF RAY, BU                       00277200
C                                                                       00277300
          BU(I+1) = GNU*BU(I) + BY(I)*X(I)                              00277400
C                                                                       00277500
C                CALCULATE HEIGHT OF CHIEF RAY, BY                      00277600
C                                                                       00277700
          BY(I+1) = BY(I) + BU(I+1)*T(I)                                00277800
          SGN1 = SGN2                                                   00277900
  450   CONTINUE                                                        00278000
        GO TO (280,460), ISW                                            00278100
  460   IF ( DABS(U(NSURF)).LT.EPS ) GO TO 470                          00278200
C                                                                       00278300
C                FTN IS FINAL THICKNESS                                 00278400
C                                                                       00278500
        FTN = ( FXYJ-XY(NSURF-1) )/U(NSURF)                             00278600
C                                                                       00278700
C                RMAG IS LATERAL MAGNIFICATION                          00278800
C                                                                       00278900
        RMAG=U(1)/U(NSURF)                                              00279000
        GO TO 480                                                       00279100
  470   FTN=1.E20                                                       00279200
        RMAG=1.E20                                                      00279300
  480   IF ( DABS(BU(NSURF)).LT.EPS ) GO TO 490                         00279400
C                                                                       00279500
C                FTNB IS IMAGE DIST PRINCIPAL RAY                       00279600
C                                                                       00279700
        FTNB = -BY(NSURF-1)/BU(NSURF)                                   00279800
        GO TO 500                                                       00279900
  490   FTNB=1.E20                                                      00280000
C                                                                       00280100
C                PHI IS OPTICAL INVARIANT                               00280200
C                                                                       00280300
  500   PHI=TM1A*(BY(1)*U(1)-XY(1)*BU(1))                               00280400
C                                                                       00280500
C                COMPUTE ABERRATION COEFFICIENTS                        00280600
C                                                                       00280700
C             B(I)   -   SPHERICAL ABERRATION                           00280800
C             CC(I)  -   ASTIGMATISM                                    00280900
C             F(I)   -   COMA                                           00281000
C             E(I)   -   DISTORTION                                     00281100
C             P(I)   -   PETZVAL                                        00281200
C             ACH(I) -   AXIAL CHROMATIC ABERRATION                     00281300
C             BCH(I) -   LATERAL CHROMATIC ABERRATION                   00281400
C                                                                       00281500
C                    OTHER                                              00281600
C                                                                       00281700
C             TM2    -   SGN1*N                                         00281800
C             TM1    -   SGN2*N'                                        00281900
C                                                                       00282000
        SP    = ZERO                                                    00282100
        DN1   = ZERO                                                    00282200
        DN2   = ZERO                                                    00282300
        CO    = ZERO                                                    00282400
        AS    = ZERO                                                    00282500
        DIS   = ZERO                                                    00282600
        PET   = ZERO                                                    00282700
        TACH  = ZERO                                                    00282800
        TCH   = ZERO                                                    00282900
        CSPH  = ZERO                                                    00283000
        CCOM  = ZERO                                                    00283100
        CAST  = ZERO                                                    00283200
        CDIST = ZERO                                                    00283300
        L=NSURF-1                                                       00283400
        SGN1 = FREF0                                                    00283500
C                                                                       00283600
        DO 590 I = 1, L                                                 00283700
          SGN2 = SGN1                                                   00283800
          IF (FREF(I).EQ.-ONE) SGN2 = -SGN1                             00283900
          TM1=SGN2*FN(I,LAMDA)                                          00284000
          IF (I.EQ.1) TM2 = SGN1*OBJN(LAMDA)                            00284100
          IF (I.GT.1) TM2 = SGN1*FN(I-1,LAMDA)                          00284200
          IF ( RR(I).EQ.ZERO ) TM3 = ZERO                               00284300
          IF ( RR(I).NE.ZERO ) TM3=1./RR(I)                             00284400
          GNU = TM2/TM1                                                 00284500
          EN=XY(I)*TM3+U(I)                                             00284600
          SS=XY(I)*TM2*(GNU-ONE)*(U(I+1)+EN)                            00284700
          B(I)=SS*EN*EN                                                 00284800
          BEN=BY(I)*TM3+BU(I)                                           00284900
          F(I)=SS*EN*BEN                                                00285000
          CC(I)=SS*BEN*BEN                                              00285100
          P(I)=C(I)*(GNU-ONE)/TM2                                       00285200
          BS=BY(I)*TM2*(GNU-ONE)*(BU(I+1)+BEN)                          00285300
          E(I)=BS*EN*BEN+PHI*(BU(I)*BU(I)-BU(I+1)*BU(I+1))              00285400
          DFCN = ZERO                                                   00285500
          IF (NCOL.EQ.1) GO TO 560                                      00285600
              IA=I-1                                                    00285700
              IF (I.NE.1) GO TO 550                                     00285800
                 DN1=SGN1*((OBJN(3)-OBJN(1))/OBJN(2))                   00285900
              GO TO 555                                                 00286000
C                                                                       00286100
  550         DN1=SGN1*((FN(IA,3)-FN(IA,1))/FN(IA,2))                   00286200
  555         DN2=SGN2*((FN(I,3)-FN(I,1))/FN(I,2))                      00286300
  560     DFCN = DN1-DN2                                                00286400
C                                                                       00286500
          ACH(I)=XY(I) * TM2 * EN*DFCN                                  00286600
          BCH(I)=XY(I) * TM2 * BEN*DFCN                                 00286700
C                                                                       00286800
C                ACCUMULATE TOTAL ABERRATIONS                           00286900
C                                                                       00287000
          SP=B(I)+SP                                                    00287100
          CO=F(I)+CO                                                    00287200
          AS=CC(I)+AS                                                   00287300
          DIS=E(I)+DIS                                                  00287400
          PET=P(I)+PET                                                  00287500
          TACH=TACH-ACH(I)                                              00287600
          TCH=TCH-BCH(I)                                                00287700
          YSQ=XY(I)*XY(I)                                               00287800
C                                                                       00287900
C                FIND ASPHERICAL COEFFICIENTS                           00288000
C                                                                       00288100
          BAS(I)=8.0*TM1*(GNU-ONE)*YSQ*YSQ*DUM(I)                       00288200
          FAS(I)=BAS(I)*BY(I)/XY(I)                                     00288300
          IF (BAS(I).EQ.ZERO) GO TO 570                                 00288400
          CAS(I)=FAS(I)*FAS(I)/BAS(I)                                   00288500
          GO TO 580                                                     00288600
  570     CAS(I)=ZERO                                                   00288700
  580     EAS(I)=CAS(I)*BY(I)/XY(I)                                     00288800
          CSPH=BAS(I)+CSPH                                              00288900
          CCOM=FAS(I)+CCOM                                              00289000
          CAST=CAS(I)+CAST                                              00289100
          CDIST=EAS(I)+CDIST                                            00289200
          SGN1 = SGN2                                                   00289300
  590   CONTINUE                                                        00289400
C                                                                       00289500
C NSURF = NUMBER OF LAST SURFACE WHICH IS A DUMMY SURFACE               00289600
C            L = NUMBER OF LAST REAL SURFACE                            00289700
C            LAMDA = # OF THE COLOR (SET NEAR LINE LABELED 355 OR 360)  00289800
C                                                                       00289900
        TACH = TACH/( SGN1 * U(L) * FN(L, LAMDA) )                      00290000
        TCH  = TCH /( SGN1 * U(L) * FN(L, LAMDA) )                      00290100
C                                                                       00290200
C                TAKE SUMS OF ABERRATIONS                               00290300
C                                                                       00290400
        ABB=CSPH+SP                                                     00290500
        ABF=CCOM+CO                                                     00290600
        ABC=CAST+AS                                                     00290700
        ABE=CDIST+DIS                                                   00290800
        VAL=ABB*ABB+ABF*ABF+ABC*ABC+ABE*ABE                             00290900
        VALUE=DSQRT(VAL)                                                00291000
        VAL1=DSQRT(PET*PET+TACH*TACH+TCH*TCH)                           00291100
C                                                                       00291200
C             PRINT THE WHOLE MESS AT ONE WHACK                         00291300
C                                                                       00291400
        IF (IPRINB.EQ.1 ) GO TO 655                                     00291500
        IF (IPRINA.EQ.0 ) GO TO 610                                     00291600
C                                                                       00291700
        CALL HEADIN(LAMDA)                                              00291800
C                                                                       00291900
        WRITE(6,10)  XY(1),U(1),BY(1),BU(1),FXYJ                        00292000
        WRITE(6,30)                                                     00292100
        L=NSURF                                                         00292200
        DO 600 I=1,L                                                    00292300
          IF ( I.NE.L ) WRITE(6,40) I,XY(I),U(I+1),BY(I),BU(I+1)        00292400
          IF ( I.EQ.L ) WRITE(6,40) I,XY(I),U(I),BY(I),BU(I)            00292500
  600   CONTINUE                                                        00292600
C                                                                       00292700
C             PRINT SURFACE TYPE IF TORIC/CYLINDER                      00292800
C                                                                       00292900
        IF (ISURFX.EQ.2) WRITE(6,230) ISURXN,RSAVE                      00293000
        IF (ISURFX.EQ.3) WRITE(6,240) ISURXN,RSAVE                      00293100
        IF (ISURFX.EQ.4) WRITE(6,250) ISURXN,RSAVE                      00293200
  610   IF ( DABS(U(1)).LT.EPS ) GO TO 630                              00293300
        U(1)=ZERO                                                       00293400
        XY(1)=RHO                                                       00293500
        SGN1 = FREF0                                                    00293600
        DO 620 I=1,L                                                    00293700
          SGN2 = SGN1                                                   00293800
          IF (FREF(I).EQ.-ONE) SGN2 = -SGN1                             00293900
          TM1=SGN2*FN(I,LAMDA)                                          00294000
          IF (I.EQ.1) TM2 = SGN1*OBJN(LAMDA)                            00294100
          IF (I.GT.1) TM2 = SGN1*FN(I-1,LAMDA)                          00294200
          TM3=C(I)                                                      00294300
          CALL SURTYP (I)                                               00294400
          GNU = TM2/TM1                                                 00294500
          XI = TM3 * (GNU-ONE)                                          00294600
          U(I+1)=GNU*U(I)+XY(I)*XI                                      00294700
          XY(I+1)=XY(I)+U(I+1)*T(I)                                     00294800
          SGN1 = SGN2                                                   00294900
  620   CONTINUE                                                        00295000
  630   FOCL=-XY(1)/U(NSURF)                                            00295100
        FNUM=DABS(.5/U(NSURF))                                          00295200
        WRITE(6,60) FTN,RMAG,FTNB,FOCL,FNUM                             00295300
        L = NSURF-1                                                     00295400
  655   WRITE(6,70)                                                     00295500
        DO 660 I=1,L                                                    00295600
          WRITE(6,80) I,B(I),F(I),CC(I),E(I),P(I),ACH(I),BCH(I)         00295700
          IF (RCON(I).EQ.ZERO .AND. COEF(I,1).EQ.ZERO) GO TO 660        00295800
          WRITE(6,100) I,BAS(I),FAS(I),CAS(I),EAS(I)                    00295900
  660   CONTINUE                                                        00296000
        WRITE(6,110) SP,CO,AS,DIS,PET,TACH,TCH                          00296100
        WRITE(6,120) CSPH,CCOM,CAST,CDIST                               00296200
        WRITE(6,130) ABB,ABF,ABC,ABE,PET,TACH,TCH                       00296300
        WRITE(6,140) VALUE                                              00296400
        WRITE(6,150) VAL1                                               00296500
  680 CONTINUE                                                          00296600
C                                                                       00296700
C       COLORS LOOP - EXIT                                              00296800
C                                                                       00296900
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC           00297000
C       PRINCIPLE RETURN                                                00297100
C                                                                       00297200
  682 RETURN                                                            00297300
C                                                                       00297400
C***********************************************************            00297500
C                                                                       00297600
C                                                                       00297700
C                RITCHEY-CHRETIEN- TELESCOPE DESIGN ROUTINE             00297800
C                                                                       00297900
      ENTRY RCDES                                                       00298000
      FP = -R(2)/TWO                                                    00298100
      FSY = -XY(1)/U(NSURF)                                             00298200
      BF  = T(2) + (FXYJ-XY(3))/U(NSURF)                                00298300
      A   = FSY/FP                                                      00298400
      V = TWO*(FP+BF)/(A*A*(FSY-BF))                                    00298500
      CONIC(2) = -(ONE+V)                                               00298600
      V = (TWO*FSY*(A+ONE))/((A-ONE)*(A-ONE)*(A-ONE)*(FSY-BF))          00298700
      V   = V + (4.D0*A/((A-ONE)*(A-ONE)))                              00298800
      CONIC(3) = -(ONE+V)                                               00298900
      WRITE(6,170) CONIC(2)                                             00299000
      WRITE(6,180) CONIC(3)                                             00299100
      IPRINB=1                                                          00299200
      GO TO 370                                                         00299300
C                                                                       00299400
C                CASSEGRAIN TELESCOPE DESIGN ROUTINE                    00299500
C                                                                       00299600
      ENTRY CADES                                                       00299700
      CONIC(2)=-ONE                                                     00299800
      BF=(FXYJ-XY(3))/U(4)                                              00299900
      FP=-R(2)/2.                                                       00300000
      V=(BF+FP+T(2))/(BF-FP-T(2))                                       00300100
      CONIC(3)=-V*V                                                     00300200
      T(3)=BF                                                           00300300
      WRITE(6,170) CONIC(2)                                             00300400
      WRITE(6,180) CONIC(3)                                             00300500
      IPRINB=1                                                          00300600
      GO TO 370                                                         00300700
C                                                                       00300800
C                DAHL-KIRKHAM TELESCOPE DESIGN ROUTINE                  00300900
C                                                                       00301000
      ENTRY DKDES                                                       00301100
      CONIC(3)=ZERO                                                     00301200
      BF=(FXYJ-XY(3))/U(4) + T(2)                                       00301300
      PF=-R(2)/2.                                                       00301400
      A=FOCL/PF                                                         00301500
      V=(PF+BF)/(A+1.)                                                  00301600
      PP=PF+BF-V                                                        00301700
      RS=-(2.*V*PP)/(PP-V)                                              00301800
      CONIC(2)=-(1.-4.*V*V*(PP+V)*(PP+V)/(RS*R(2)*PP*PP))               00301900
      WRITE(6,170) CONIC(2)                                             00302000
      WRITE(6,180) CONIC(3)                                             00302100
      ECC = CONIC(2)                                                    00302200
      F1=R(2)/(1.-ECC)                                                  00302300
      F2=R(2)/(1.+ECC)                                                  00302400
      WRITE(6,220) F1,F2                                                00302500
      IPRINB=1                                                          00302600
      GO TO 370                                                         00302700
      END                                                               00302800
C                                                                       00302900
C*******************************************************                00303000
      SUBROUTINE PREPRT                                                 00303100
C*******************************************************                00303200
C             PRINTS OPTICAL PRESCRIPTION DATA                          00303300
      IMPLICIT REAL*8 (A-H,O-Z)                                         00303400
C                                                                       00303500
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00303600
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00303700
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00303800
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00303900
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00304000
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00304100
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00304200
     $                FREF(40),FREF0,WAVL(3)                            00304300
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00304400
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00304500
     $                IPR20,IREF,IJK,IALLPL                             00304600
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00304700
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00304800
C                                                                       00304900
      DIMENSION XT(300),YT(300),IFLAG(40),XTH(300),YTH(300),IORDER(3)   00305000
C                                                                       00305100
      DATA PI/3.141592653589793D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/      00305200
      DATA FOUR/4.D0/,FIVE/5.D0/,ZERO/0.D0/,CLEAR/'CLEAR'/,OBSC/'OBSC'/ 00305300
      DATA TYPE/'        '/                                             00305400
      DATA IZERO/0/,IONE/1/,ITWO/2/                                     00305500
C                                                                       00305600
C             PRINT HEADING                                             00305700
      CALL HEADIN(0)                                                    00305800
C                                                                       00305900
C             PRINT 'SURFACE DATA' CARD                                 00306000
      WRITE (6,200)                                                     00306100
C                                                                       00306200
C             PRINT OBJECT DATA                                         00306300
      WRITE (6,210)                                                     00306400
      NOBJ=RNOBJ                                                        00306500
      DO 10 I=1,NOBJ                                                    00306600
        IF ( NOBJ.EQ.0 ) GO TO 10                                       00306700
        RI=I                                                            00306800
        XT(I)=HXINIT+(RI-ONE)*HXDEL                                     00306900
        YT(I)=HYINIT+(RI-ONE)*HYDEL                                     00307000
        XTH(I)=-DTAN(XT(I)*PI/180.D0)*(S-D)                             00307100
        YTH(I)=-DTAN(YT(I)*PI/180.D0)*(S-D)                             00307200
   10 CONTINUE                                                          00307300
      WRITE (6,260) S                                                   00307400
      IF ( OBJN(2).EQ.ONE .AND. FREF0.EQ.ONE ) WRITE(6,262)             00307500
      IF ( OBJN(2).EQ.ONE .AND. FREF0.EQ.-ONE) WRITE(6,264)             00307600
      IF ( OBJN(2).NE.ONE .AND. FREF0.EQ.ONE ) WRITE(6,266) OBJN(2)     00307700
      JOBJ=NOBJ                                                         00307800
      KADD=0                                                            00307900
      NPR1=6                                                            00308000
      IF (NOBJ.LT.6) NPR1=NOBJ                                          00308100
      IF ( NOBJ.NE.0 ) WRITE (6,220) (XT(J),J=1,NPR1)                   00308200
   11 JOBJ=JOBJ-6                                                       00308300
      KADD=KADD+6                                                       00308400
      IF ( JOBJ.LE.0 ) GO TO 12                                         00308500
      NPR2=6                                                            00308600
      IF (JOBJ.LT.6) NPR2=JOBJ                                          00308700
      WRITE (6,222) (XT(J+KADD),J=1,NPR2)                               00308800
      GO TO 11                                                          00308900
   12 JOBJ=NOBJ                                                         00309000
      KADD=0                                                            00309100
      IF ( NOBJ.NE.0 ) WRITE (6,230) (YT(J),J=1,NPR1)                   00309200
   13 JOBJ=JOBJ-6                                                       00309300
      KADD=KADD+6                                                       00309400
      IF (JOBJ.LE.0) GO TO 14                                           00309500
      NPR2=6                                                            00309600
      IF (JOBJ.LT.6) NPR2=JOBJ                                          00309700
      WRITE(6,222) (YT(J+KADD),J=1,NPR2)                                00309800
      GO TO 13                                                          00309900
   14 JOBJ=NOBJ                                                         00310000
      KADD=0                                                            00310100
      IF ( NOBJ.NE.0 ) WRITE (6,240) (XTH(J),J=1,NPR1)                  00310200
   15 JOBJ=JOBJ-6                                                       00310300
      KADD=KADD+6                                                       00310400
      IF (JOBJ.LE.0) GO TO 16                                           00310500
      NPR2=6                                                            00310600
      IF (JOBJ.LT.6) NPR2=JOBJ                                          00310700
      WRITE(6,222) (XTH(J+KADD),J=1,NPR2)                               00310800
      GO TO 15                                                          00310900
   16 JOBJ=NOBJ                                                         00311000
      KADD=0                                                            00311100
      IF ( NOBJ.NE.0 ) WRITE (6,250) (YTH(J),J=1,NPR1)                  00311200
   17 JOBJ=JOBJ-6                                                       00311300
      KADD=KADD+6                                                       00311400
      IF (JOBJ.LE.0) GO TO 18                                           00311500
      NPR2=6                                                            00311600
      IF (JOBJ.LT.6) NPR2=JOBJ                                          00311700
      WRITE(6,222) (YTH(J+KADD),J=1,NPR2)                               00311800
      GO TO 17                                                          00311900
   18 IF ( NOBJ.EQ.0 ) WRITE(6,220)                                     00312000
      IF ( NOBJ.EQ.0 ) WRITE(6,230)                                     00312100
      IF ( NOBJ.EQ.0 ) WRITE(6,240)                                     00312200
      IF ( NOBJ.EQ.0 ) WRITE(6,250)                                     00312300
C                                                                       00312400
C                                                                       00312500
C             WRITE IMAGE SURFACE DATA                                  00312600
      IF (RADIMG.NE.ZERO) WRITE(6,270) NPLANE,DELIMP,CVIMG,RADIMG,CONIMG00312700
      IF (RADIMG.EQ.ZERO) WRITE(6,275) NPLANE,DELIMP,CVIMG,CONIMG       00312800
C                                                                       00312900
C             WRITE SYSTEM UNITS                                        00313000
      WRITE(6,277)                                                      00313100
      IF (UFLAG.EQ.ONE)   WRITE (6,280)                                 00313200
      IF (UFLAG.EQ.TWO)   WRITE (6,290)                                 00313300
      IF (UFLAG.EQ.THREE) WRITE (6,300)                                 00313400
      IF (UFLAG.EQ.FOUR)  WRITE (6,310)                                 00313500
      IF (UFLAG.EQ.FIVE)  WRITE (6,320)                                 00313600
C             IF UFLAG NONE OF ABOVE, UNKNOWN UNITS                     00313700
      IF ( UFLAG.LT.ONE .OR. UFLAG.GT.FIVE ) WRITE (6,330) UFLAG        00313800
C                                                                       00313900
C             WRITE ENTRANCE PUPIL DATA                                 00314000
      DIAM=TWO*ENPUPR                                                   00314100
      WRITE (6,340) DIAM,ENPUPL                                         00314200
C                                                                       00314300
C             WRITE EXIT PUPIL DATA                                     00314400
      DIAM=TWO*EXPUPR                                                   00314500
      WRITE (6,350) DIAM,EXPUPL                                         00314600
      IF ( APSTOP.NE.ZERO ) ISTOP = APSTOP/30.D0                        00314700
      IF ( APSTOP.NE.ZERO ) WRITE(6,353) ISTOP                          00314800
      IF ( APSTOP.EQ.ZERO ) WRITE(6,355)                                00314900
      IF ( IREF.LE.0 ) WRITE(6,357)                                     00315000
      IF ( IREF.GT.0 ) WRITE(6,358) IREF                                00315100
C                                                                       00315200
C             WRITE BASIC SURFACE DATA                                  00315300
      WRITE (6,360)                                                     00315400
      DO 20 I=1,NSURF                                                   00315500
        IF (R(I).EQ.ZERO .AND. FREF(I).EQ.ONE .AND. FN(I,2).EQ.ONE )    00315600
     $       WRITE(6,370) I,C(I),CONIC(I),T(I)                          00315700
        IF ( R(I).NE.ZERO .AND. FREF(I).EQ.ONE .AND. FN(I,2).EQ.ONE )   00315800
     $       WRITE(6,372) I,C(I),R(I),CONIC(I),T(I)                     00315900
        IF ( R(I).EQ.ZERO .AND. FREF(I).EQ.-ONE .AND. FN(I,2).EQ.ONE )  00316000
     $       WRITE(6,374) I,C(I),CONIC(I),T(I)                          00316100
        IF ( R(I).NE.ZERO .AND. FREF(I).EQ.-ONE .AND. FN(I,2).EQ.ONE )  00316200
     $       WRITE(6,376) I,C(I),R(I),CONIC(I),T(I)                     00316300
        IF ( R(I).EQ.ZERO .AND. FN(I,2).NE.ONE )                        00316400
     $       WRITE(6,377) I,C(I),CONIC(I),T(I),(FN(I,J),J=1,3)          00316500
        IF ( R(I).NE.ZERO .AND. FN(I,2).NE.ONE )                        00316600
     $       WRITE(6,378) I,C(I),R(I),CONIC(I),T(I),(FN(I,J),J=1,3)     00316700
   20 CONTINUE                                                          00316800
C                                                                       00316900
C             WRITE ACONIC SURFACE DATA, IF ANY                         00317000
      ICONIC=0                                                          00317100
      DO 40 I=1,NSURF                                                   00317200
        IFLAG(I)=0                                                      00317300
        DO 30 J=1,4                                                     00317400
          IF (COEF(I,J).EQ.ZERO) GO TO 30                               00317500
          IFLAG(I)=1                                                    00317600
          ICONIC=1                                                      00317700
          GO TO 40                                                      00317800
   30   CONTINUE                                                        00317900
   40 CONTINUE                                                          00318000
C                                                                       00318100
      IF (ICONIC.EQ.0) GO TO 60                                         00318200
      WRITE (6,380)                                                     00318300
      DO 50 I=1,NSURF                                                   00318400
        IF (IFLAG(I).EQ.0) GO TO 50                                     00318500
        WRITE (6,390) I,(COEF(I,J),J=1,4)                               00318600
   50 CONTINUE                                                          00318700
C                                                                       00318800
C             WRITE TILT/DISPLACEMENT DATA, IF ANY                      00318900
   60 ITILT=0                                                           00319000
      DO 70 I=1,NSURF                                                   00319100
        IFLAG(I)=0                                                      00319200
        IF (XDISP(I).EQ.ZERO.AND.YDISP(I).EQ.ZERO.AND.TILTX(I).EQ.ZERO.A00319300
     $  ND.TILTY(I).EQ.ZERO.AND.TILTZ(I).EQ.ZERO) GO TO 70              00319400
        IFLAG(I)=1                                                      00319500
        ITILT=1                                                         00319600
   70 CONTINUE                                                          00319700
C                                                                       00319800
      IF (ITILT.EQ.0) GO TO 90                                          00319900
      WRITE (6,400)                                                     00320000
      DO 80 I=1,NSURF                                                   00320100
        IF (IFLAG(I).EQ.0) GO TO 80                                     00320200
        WRITE (6,410) I,XDISP(I),YDISP(I),TILTX(I),TILTY(I),TILTZ(I)    00320300
        IF (DABS(FAKEB(I)).EQ.ONE) WRITE (6,420)                        00320400
        IF (DABS(FAKEB(I)).EQ.TWO) WRITE (6,430)                        00320500
        IF (DABS(FAKEB(I)).EQ.THREE) WRITE (6,440)                      00320600
   80 CONTINUE                                                          00320700
C                                                                       00320800
C             WRITE GRATING DATA, IF ANY                                00320900
   90 IGRAT=0                                                           00321000
      DO 100 I=1,NSURF                                                  00321100
        IFLAG(I)=0                                                      00321200
        IF (RDSPAC(I).EQ.ZERO) GO TO 100                                00321300
        IFLAG(I)=1                                                      00321400
        IGRAT=1                                                         00321500
  100 CONTINUE                                                          00321600
C                                                                       00321700
      IF (IGRAT.EQ.0) GO TO 120                                         00321800
      WRITE (6,450)                                                     00321900
      DO 110 I=1,NSURF                                                  00322000
        IF (IFLAG(I).EQ.0) GO TO 110                                    00322100
        SPACE=DABS(RDSPAC(I))                                           00322200
        DO 105 K=1,3                                                    00322300
        IORDER(K)=ORDN(I,K)                                             00322400
        IF (RDSPAC(I).LT.ZERO)                                          00322500
     $     WRITE(6,460) I,WAVL(K),IORDER(K),SPACE                       00322600
        IF (RDSPAC(I).GT.ZERO)                                          00322700
     $     WRITE(6,470) I,WAVL(K),IORDER(K),SPACE                       00322800
  105 CONTINUE                                                          00322900
  110 CONTINUE                                                          00323000
C                                                                       00323100
C             WRITE TORIC DATA, IF ANY                                  00323200
  120 ITOR=0                                                            00323300
      DO 130 I=1,NSURF                                                  00323400
        IFLAG(I)=0                                                      00323500
        TOR=Y0(I)                                                       00323600
        IF (TOR.NE.ONE) GO TO 130                                       00323700
        IFLAG(I)=1                                                      00323800
        ITOR=1                                                          00323900
  130 CONTINUE                                                          00324000
C                                                                       00324100
      IF (ITOR.EQ.0) GO TO 150                                          00324200
      WRITE (6,480)                                                     00324300
      DO 140 I=1,NSURF                                                  00324400
        IF (IFLAG(I).EQ.0) GO TO 140                                    00324500
        IF ( RX(I).NE.ZERO ) WRITE (6,490) I,CX(I),RX(I)                00324600
         IF ( RX(I).EQ.ZERO ) WRITE (6,495) I,CX(I)                     00324700
  140 CONTINUE                                                          00324800
C                                                                       00324900
C             WRITE MASK DATA, IF ANY                                   00325000
  150 IMASKC=0                                                          00325100
      IMASKR=0                                                          00325200
      IMASKE=0                                                          00325300
      DO 160 I=1,NSURF                                                  00325400
        IFLAG(I)=0                                                      00325500
        IF (FMASK(I).EQ.ZERO) GO TO 160                                 00325600
        IFLAG(I)=1                                                      00325700
        IF (FAKEC(I).GT.0) IMASKR=1                                     00325800
        IF (FAKEC(I).EQ.0) IMASKC=1                                     00325900
        IF (FAKEC(I).LT.0) IMASKE=1                                     00326000
        IMASK=1                                                         00326100
  160 CONTINUE                                                          00326200
C                                                                       00326300
      IF (IMASKC+IMASKE+IMASKR.EQ.0) GO TO 190                          00326400
      WRITE(6,499)                                                      00326500
      IF (IMASKC.EQ.0) GO TO 182                                        00326600
      WRITE (6,500)                                                     00326700
      DO 180 I=1,NSURF                                                  00326800
        IF (IFLAG(I).EQ.0) GO TO 180                                    00326900
        IF ( FAKEC(I).NE.0) GO TO 180                                   00327000
        IF (FMASK(I).LT.ZERO) TYPE=OBSC                                 00327100
        IF (FMASK(I).GT.ZERO) TYPE=CLEAR                                00327200
        RMASK=FMASK(I)                                                  00327300
        XCEN=XMN(I)                                                     00327400
        YCEN=YMN(I)                                                     00327500
        XMIN=ZERO                                                       00327600
        XMAX=ZERO                                                       00327700
        YMIN=ZERO                                                       00327800
        YMAX=ZERO                                                       00327900
  170   WRITE (6,510) I,TYPE,RMASK,XCEN,YCEN                            00328000
  180 CONTINUE                                                          00328100
C                                                                       00328200
  182 IF (IMASKR.EQ.0) GO TO 186                                        00328300
      WRITE(6,501)                                                      00328400
      DO 185 I=1,NSURF                                                  00328500
        IF (IFLAG(I).EQ.0) GO TO 185                                    00328600
        IF (FAKEC(I).NE.1) GO TO 185                                    00328700
        IF (FMASK(I).LT.0) TYPE=OBSC                                    00328800
        IF (FMASK(I).GT.0) TYPE=CLEAR                                   00328900
        RMASK=0                                                         00329000
        XCEN=0                                                          00329100
        YCEN=0                                                          00329200
        XMIN=XMN(I)                                                     00329300
        XMAX=XMX(I)                                                     00329400
        YMIN=YMN(I)                                                     00329500
        YMAX=YMX(I)                                                     00329600
        WRITE(6,511) I,TYPE,XMIN,XMAX,YMIN,YMAX                         00329700
  185 CONTINUE                                                          00329800
C                                                                       00329900
  186 IF (IMASKE.EQ.0) GO TO 190                                        00330000
      WRITE(6,502)                                                      00330100
      DO 188 I=1,NSURF                                                  00330200
         IF (IFLAG(I).EQ.0) GO TO 188                                   00330300
         IF (FAKEC(I).NE.-1) GO TO 188                                  00330400
         IF (FMASK(I).LT.0) TYPE=OBSC                                   00330500
         IF (FMASK(I).GT.0) TYPE=CLEAR                                  00330600
         RMASK=0                                                        00330700
         YMIN=0                                                         00330800
         XMIN=0                                                         00330900
         YMAX=YMX(I)                                                    00331000
         XMAX=XMX(I)                                                    00331100
         YCEN=YMN(I)                                                    00331200
         XCEN=XMN(I)                                                    00331300
         WRITE(6,511) I,TYPE,XMAX,YMAX,XCEN,YCEN                        00331400
  188 CONTINUE                                                          00331500
C                                                                       00331600
  190 WRITE (6,520)                                                     00331700
C                                                                       00331800
C             TURN OFF LEPRT SWITCH                                     00331900
  195 IF ( IPRINT.NE.IZERO.AND.(IPRINT/ITWO)*ITWO.NE.IPRINT)            00332000
     $     IPRINT = IPRINT-IONE                                         00332100
C                                                                       00332200
      RETURN                                                            00332300
  200 FORMAT (///T45,'OPTICAL PRESCRIPTION DATA')                       00332400
  210 FORMAT (//T37,'----------     OBJECT DATA      ----------'/)      00332500
  214 FORMAT (T10,'WRITING ONLY FIRST 6 OBJECT POINTS'//)               00332600
  220 FORMAT (T10,'X OBJECT ANGLES : ',1X,6(1PE13.6,1X))                00332700
  222 FORMAT (T29,6(1PE13.6,1X))                                        00332800
  230 FORMAT (T10,'Y OBJECT ANGLES : ',1X,6(1PE13.6,1X))                00332900
  240 FORMAT (/T10,'X OBJECT HEIGHTS: ',1X,6(1PE13.6,1X))               00333000
  250 FORMAT (T10,'Y OBJECT HEIGHTS: ',1X,6(1PE13.6,1X))                00333100
  260 FORMAT (T10,'OBJECT DISTANCE = ',1X,1PE16.9)                      00333200
  262 FORMAT (T10,'OBJECT INDEX    =   AIR'/)                           00333300
  264 FORMAT (T10,'OBJECT INDEX    =   REFLECT'/)                       00333400
  266 FORMAT (T10,'OBJECT INDEX    = ',1X,0PF9.6/)                      00333500
  270 FORMAT (//T37,'----------  IMAGE SURFACE DATA  ----------',       00333600
     $       //T10,'NUMBER OF SURFACES = ',                             00333700
     $       1X,I2,/T10,'SEPARATION         = ',1X,1PE16.9,             00333800
     $       /T10,'CURVATURE          = ',1X,1PE16.9,                   00333900
     $       5X,'( RADIUS = ',1PE16.9,1X,')',                           00334000
     $       /T10,'CONIC CONSTANT     = ',1X,0PF9.6)                    00334100
  275 FORMAT (//T37,'----------  IMAGE SURFACE DATA  ----------',       00334200
     $       //T10,'NUMBER OF SURFACES = ',                             00334300
     $       1X,I2,/T10,'SEPARATION         = ',1X,1PE16.9,             00334400
     $       /T10,'CURVATURE          = ',1X,1PE16.9,                   00334500
     $       5X,'( INFINITE RADIUS )',                                  00334600
     $       /T10,'CONIC CONSTANT     = ',1X,0PF9.6)                    00334700
  277 FORMAT(//T37,'----------     SYSTEM UNITS     ----------')        00334800
  280 FORMAT (//T10,'SYSTEM UNITS ARE MILLIMETERS')                     00334900
  290 FORMAT (//T10,'SYSTEM UNITS ARE CENTIMETERS')                     00335000
  300 FORMAT (//T10,'SYSTEM UNITS ARE INCHES')                          00335100
  310 FORMAT (//T10,'SYSTEM UNITS ARE TANGENTS OF ANGLES')              00335200
  320 FORMAT (//T10,'SYSTEM UNITS ARE ANGLES OF INCIDENCE')             00335300
  330 FORMAT (//T10,'UNDEFINED SYSTEM UNITS; UFLAG = ',0PF5.1)          00335400
  340 FORMAT (//T37,'---------- ENTRANCE PUPIL DATA  ----------',       00335500
     $       //T10,'DIAMETER                   = ',1PE16.8,             00335600
     $       /T10,'DISTANCE TO FIRST SURFACE  = ',1PE16.8)              00335700
  350 FORMAT (//T37,'----------   EXIT PUPIL DATA    ----------',       00335800
     $       //T10,'DIAMETER                    = ',1PE16.8,            00335900
     $       /T10,'DISTANCE FROM LAST SURFACE  = ',1PE16.8)             00336000
  353 FORMAT (//T9,' APERTURE STOP AT SURFACE ',I4)                     00336100
  355 FORMAT (//T9,' NO APERTURE STOP DESIGNATED')                      00336200
  357 FORMAT (//T9,' NO REFERENCE SURFACE DESIGNATED')                  00336300
  358 FORMAT (//T9,' REFERENCE SURFACE AT SURFACE ',I4)                 00336400
  360 FORMAT (//T37,'----------  BASIC SURFACE DATA  ----------',       00336500
     $       //T5,'SURF',T13,'CURVATURE',T32,                           00336600
     $       'RADIUS',T48,'CONIC',T63,'THICKNESS',T82,'INDICES'/)       00336700
  370 FORMAT(T5,I4,T10,1PE15.8,T31,'INFINITE',T46,0PF9.6,T60,1PE15.8,   00336800
     $       T78,'AIR')                                                 00336900
  372 FORMAT(T5,I4,T10,1PE15.8,T28,1PE15.8,T46,0PF9.6,T60,1PE15.8,      00337000
     $       T78,'AIR')                                                 00337100
  374 FORMAT(T5,I4,T10,1PE15.8,T31,'INFINITE',T46,0PF9.6,T60,1PE15.8,   00337200
     $       T78,'REFLECT')                                             00337300
  376 FORMAT(T5,I4,T10,1PE15.8,T28,1PE15.8,T46,0PF9.6,T60,1PE15.8,      00337400
     $       T78,'REFLECT')                                             00337500
  377 FORMAT(T5,I4,T10,1PE15.8,T31,'INFINITE',T46,0PF9.6,T60,1PE15.8,   00337600
     $       T77,3(0PF9.6,1X) )                                         00337700
  378 FORMAT(T5,I4,T10,1PE15.8,T28,1PE15.8,T46,0PF9.6,T60,1PE15.8,      00337800
     $       T77,3(0PF9.6,1X) )                                         00337900
  380 FORMAT (//T37,'----------    ASPHERIC DATA     ----------',       00338000
     $       //T10,'SURF',T23,'4TH',T43,'6TH',                          00338100
     $       T63,'8TH',T82,'10TH'/)                                     00338200
  390 FORMAT (T10,I4,T17,1PE15.8,T37,1PE15.8,T57,1PE15.8,T77,1PE15.8)   00338300
  400 FORMAT (//T37,'----------TILT/DISPLACEMENT DATA----------',       00338400
     $       //T73,'(TILTS ARE IN DEGREES)',/T10,'SURF',T22,'X-DEC',    00338500
     $       T42,'Y-DEC',T62,'X-TILT',T80,'Y-TILT',T101,'Z-TILT'/)      00338600
  410 FORMAT (T10,I4,T17,1PE15.8,T37,1PE15.8,T57,1PE15.8,T77,1PE15.8,   00338700
     $       T97,1PE15.8)                                               00338800
  420 FORMAT (T23,'(DISPLACEMENTS ARE RESTORED)')                       00338900
  430 FORMAT (T70,'(TILTS ARE RESTORED)')                               00339000
  440 FORMAT (T23,'(DISPLACEMENTS ARE RESTORED)',T69,                   00339100
     *        T70,'(TILTS ARE RESTORED)')                               00339200
  450 FORMAT (//T37,'----------     GRATING DATA     ----------',       00339300
     $       //T10,'SURF',T21,'WAVELENGTH',T41,                         00339400
     $       'ORDER',T56,'SPACING'/)                                    00339500
  460 FORMAT (T10,I4,T19,1PE15.8,T42,I4,                                00339600
     $       T52,1PE15.8,T72,'(X RULINGS)')                             00339700
  470 FORMAT (T10,I4,T19,1PE15.8,T42,I4,                                00339800
     $       T52,1PE15.8,T72,'(Y RULINGS)')                             00339900
  480 FORMAT (//T37,'----------      TORIC DATA      ----------',       00340000
     $       //T10,'SURF',T20,'CURVATURE',T39,                          00340100
     $       'RADIUS'/)                                                 00340200
  490 FORMAT (T10,I4,T17,1PE15.8,T35,1PE15.8)                           00340300
  495 FORMAT(T10,I4,T17,1PE15.8,T37,'INFINITE')                         00340400
  499 FORMAT (//T37,'----------      MASK DATA       ----------')       00340500
  500 FORMAT (    //T32,'CIRCULAR',                                     00340600
     $       //T3,'SURF',T10,'TYPE',T20,'RADIUS',T32,'X CENTER',T45,    00340700
     $       'Y CENTER'/)                                               00340800
  501 FORMAT (//T38,'RECTANGULAR',//T3,'SURF',T10,'TYPE',               00340900
     $       T21,'X MIN',T34,'X MAX',T47,'Y MIN',T60,'Y MAX'/)          00341000
  502 FORMAT (//T38,'ELLIPTICAL',//T3,'SURF',T10,'TYPE',T21,'X MAX',    00341100
     $       T34,'Y MAX',T45,'X CENTER',                                00341200
     $       T58,'Y CENTER'/)                                           00341300
  510 FORMAT (T3,I4,T10,A5,T17,1PE12.5,T30,1PE12.5,T43,1PE12.5)         00341400
  511 FORMAT (T3,I4,T10,A5,T17,1PE12.5,T30,1PE12.5,T43,1PE12.5,         00341500
     $       T56,1PE12.5)                                               00341600
  520 FORMAT (//T45,'END OF PRESCRIPTION'///)                           00341700
      END                                                               00341800
C                                                                       00341900
C*******************************************************                00342000
      SUBROUTINE ROTM(ALPHA,BETA,GAMMA)                                 00342100
C*******************************************************                00342200
C                                                                       00342300
C                ROTM CONSTRUCTS THE ROTA ROTATION MATRIX               00342400
C                                                                       00342500
C                ALPHA = TILT ABOUT X-AXIS, IN DEGREES                  00342600
C                BETA  = TILT ABOUT (NEW) Y-AXIS, IN DEGREES            00342700
C                GAMMA = TILT ABOUT (NEW) Z-AXIS, IN DEGREES            00342800
C                ARAD  = TILT ABOUT X-AXIS, IN RADIANS                  00342900
C                BRAD  = TILT ABOUT (NEW) Y-AXIS, IN RADIANS            00343000
C                GRAD  = TILT ABOUT (NEW) Z-AXIS, IN RADIANS            00343100
C                                                                       00343200
      IMPLICIT REAL *8 (A-H,O-Z)                                        00343300
      COMMON /ROT/ ROTA(3,3)                                            00343400
      CONST = 3.14159265358979323846D0/180.                             00343500
      ARAD = ALPHA*CONST                                                00343600
      BRAD = BETA*CONST                                                 00343700
      GRAD = GAMMA*CONST                                                00343800
      CA   = DCOS(ARAD)                                                 00343900
      CB   = DCOS(BRAD)                                                 00344000
      CG   = DCOS(GRAD)                                                 00344100
      SA   = DSIN(ARAD)                                                 00344200
      SB   = DSIN(BRAD)                                                 00344300
      SG   = DSIN(GRAD)                                                 00344400
C                                                                       00344500
      ROTA(1,1) = CB*CG                                                 00344600
      ROTA(1,2) = (SA*SB*CG + CA*SG)                                    00344700
      ROTA(1,3) = -(CA*SB*CG - SA*SG)                                   00344800
      ROTA(2,1) = -CB*SG                                                00344900
      ROTA(2,2) = -(SA*SB*SG - CA*CG)                                   00345000
      ROTA(2,3) = (CA*SB*SG + SA*CG)                                    00345100
      ROTA(3,1) = SB                                                    00345200
      ROTA(3,2) = -SA*CB                                                00345300
      ROTA(3,3) = CA*CB                                                 00345400
      RETURN                                                            00345500
      END                                                               00345600
C                                                                       00345700
C*******************************************************                00345800
      SUBROUTINE SKEW (NFOC,LFOC,IFOC)                                  00345900
C*******************************************************                00346000
C                ROUTINE SKEW PERFORMS TRACING OF RAYS THROUGH          00346100
C                A SYSTEM OF UP TO 40 SURFACES                          00346200
      IMPLICIT REAL *8 (A-H,O-Z)                                        00346300
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00346400
C                                                                       00346500
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00346600
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00346700
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00346800
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00346900
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00347000
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00347100
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00347200
     $                FREF(40),FREF0,WAVL(3)                            00347300
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00347400
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00347500
     $                IPR20,IREF,IJK,IALLPL                             00347600
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00347700
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00347800
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00347900
      COMMON /CRED/   RPP(40),EPP(40),XW(812),HYSAVE,HXSAVE,            00348000
     $                TIMES,RD,OPTNE,ISW,IOPB                           00348100
      COMMON /CMTF/   AJ, AN, AR(40), DE(40), DELTCC, DELTEN, DELTPL,   00348200
     $                EN, IOPC, OPTNF, PRINAN, RSC, SUM, TX(51)         00348300
      COMMON /CSPOT/  XTMAX,XTMIN,YTMAX,YTMIN,AVGX,AVGY,RP(812),SPOTP,  00348400
     $                XK(812),YK(812),XKALL(7600),YKALL(7600),JSKIP,    00348500
     $                IOPA,NTHRU                                        00348600
C                                                                       00348700
C                                                                       00348800
C                                                                       00348900
      DIMENSION YW(812),TOR(40),XWN(812),YWN(812)                       00349000
      DIMENSION ZF(10),BLOB(10)                                         00349100
      DIMENSION XSUM(10),YSUM(10),XSUMSQ(10),YSUMSQ(10)                 00349200
      DIMENSION QT(3),XX(3),XYZ(3),GIBRSH(8)                            00349300
C                                                                       00349400
      EQUIVALENCE (QT(1),QX),(QT(2),QY),(QT(3),QZ)                      00349500
      EQUIVALENCE (XX(1),XT),(XX(2),YT),(XX(3),ZT)                      00349600
      EQUIVALENCE (XYZ(1),X),(XYZ(2),Y),(XYZ(3),Z)                      00349700
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00349800
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00349900
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00350000
      EQUIVALENCE (TRASH(10),FBNU),(Y0(1),TOR(1))                       00350100
C                                                                       00350200
C                                                                       00350300
      DATA IZERO/0/,IONE/1/                                             00350400
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/        00350500
      DATA FIVE/5.D0/,SIX/6.D0/,TEN/10.D0/,HUNDRD/100.D0/,THOUS/1000.D0/00350600
      DATA EPS1/1.D-9/,EPS2/1.D-14/,PI/3.141592653589793D0/             00350700
      DATA EPSLON/1.D-8/                                                00350800
C                                                                       00350900
   10 FORMAT (//10H  RAY NO. ,I3,/,2X,4HSURF,7X,1HX,15X,1HY,15X,1HZ,14X 00351000
     $      ,2HQX,14X,2HQY,14X,2HQZ,8X,19HOPTICAL PATH LENGTH/)         00351100
   20 FORMAT (3X,I2,1P8E16.8)                                           00351200
   30 FORMAT (//,6X,1HX,14X,1HY,14X,1HZ)                                00351300
   40 FORMAT (1P3E15.7)                                                 00351400
   50 FORMAT (3X,I2,10H RAY MISS )                                      00351500
   60 FORMAT (3X,I2,15H RAY REFLECTION)                                 00351600
   70 FORMAT (3X,I2,13H RAY VIGNETTE)                                   00351700
   80 FORMAT (13X,3HLOC,15X,2HX=,15X,2HY=,15X,2HZ=)                     00351800
   90 FORMAT (/4X,12HIMAGE PLANES,10X,6HQX/QZ=,1PE15.8,10X,6HQY/QZ=,    00351900
     $       1PE15.8)                                                   00352000
  100 FORMAT (5X,6(2X,1PE15.8))                                         00352100
  105 FORMAT (/4X,10HCOLOR NO. ,I1,4X,23HMULTIPLE OBJECT HEIGHTS,       00352200
     $       /4X,11HRAYS THRU =,I7,1X,7H REFL =,I4,1X,7H MISS =,        00352300
     $       I4,1X,7H VIGN =,I4/)                                       00352400
  110 FORMAT (/4X,10HCOLOR NO. ,I1,4X,10HY HEIGHT =,1PE15.8,4X,         00352500
     $       11HX HEIGHT = ,1PE15.8,/4X,11HRAYS THRU =,I4,1X,7H REFL =, 00352600
     $        I4,1X,7H MISS =,I4,1X,7H VIGN =,I4/)                      00352700
  120 FORMAT (13X,3HLOC,14X,4HXBAR,13X,4HYBAR,13X,4HSDVX,13X,4HSDVY,9X, 00352800
     $       11HSPOT RADIUS)                                            00352900
  130 FORMAT (3X,2HEP,1P6E16.8)                                         00353000
  140 FORMAT (10X,'NO ENTRANCE PUPIL SPECIFIED FOR FINRAY, WILL NOT ',  00353100
     $       'PERFORM RAY TRACE'/)                                      00353200
  201 FORMAT(10X,'APERTURE STOP SIZE NOT SPECIFIED, WILL NOT LOCATE ',  00353300
     $       'PARAXIAL PUPILS'/)                                        00353400
  202 FORMAT(10X,'FOUND DECENTERED SURFACE WHILE LOCATING PUPILS'/)     00353500
  203 FORMAT(10X,'NUMBER OF IMAGE SURFACES = 0 OR BAD NUMBERING'/)      00353600
  204 FORMAT(10X,'FIRST PLANE NUMBER IS NOT AN INTEGER'/)               00353700
  205 FORMAT(10X,'OVERFLOW OF LATTICE ARRAY'/)                          00353800
  206 FORMAT(10X,'NO APERTURE STOP SPECIFIED',                          00353900
     $      ', WILL NOT LOCATE PARAXIAL PUPILS'/)                       00354000
  210 FORMAT(10X,'QZ = 0 AT IMAGE, NO ANALYSIS PERFORMED'/)             00354100
  211 FORMAT(6D16.8)                                                    00354200
  212 FORMAT(8D16.8)                                                    00354300
  213 FORMAT(10X,'UNABLE TO TRACE CHIEF RAY FOR Y HEIGHT = ',1PE14.8,   00354400
     $      ' X HEIGHT = ',1PE14.8/)                                    00354500
  218 FORMAT(10X,'NUMBER OF SPOT PLOT RAYS TOO LARGE'/)                 00354600
C                                                                       00354700
      QZOLD = 0.0D0                                                     00354710
      JKSAVE=0                                                          00354800
      IF ((IPRINT/2)*2.NE.IPRINT) JKSAVE=1                              00354900
      IF (JKSAVE.EQ.1) FFXY=FXY                                         00355000
      IF (JKSAVE.EQ.1) FFXNU=FXNU                                       00355100
      IF (JKSAVE.EQ.1) FFBY=FBY                                         00355200
      IF (JKSAVE.EQ.1) FFBNU=FBNU                                       00355300
      ISTOP=APSTOP/30                                                   00355400
      IF (LATYPE.NE.4.OR.RHO.NE.0.OR.ISTOP.NE.0) GO TO 219              00355500
      WRITE(6,140)                                                      00355600
      GO TO 1910                                                        00355700
  219 LSTAT=FAKEA                                                       00355800
      IF (LSTAT.GE.1) THCK=T(LSTAT)                                     00355900
      DLMP=DELIMP                                                       00356000
      FPLN=FPLANE                                                       00356100
      NPLN=NPLANE                                                       00356200
      REWIND 20                                                         00356300
      DIV=TEN                                                           00356400
      LIMIT=800                                                         00356500
      MAXIT=6                                                           00356600
      ENPUPR = RHO                                                      00356700
      ENPUPL = D                                                        00356800
      NNSURF=NSURF                                                      00356900
      NITRAT=0                                                          00357000
C                                                                       00357100
C                A-INITIALIZATION-                                      00357200
C                ISTOP = SURFACE NUMBER OF APERTURE STOP                00357300
      ISTOP = APSTOP/30                                                 00357400
C                   IREF:  0 = FINISHED REFERENCE SURFACE ITERATIONS    00357500
C                         -1 = NO REFERENCE SURFACE ITERATIONS DESIRED  00357600
C                          1+ = NOW ITERATING TO SURFACE IREF           00357700
      IF (IREF.LE.IZERO) IREF=-1                                        00357800
      IIREF=IREF                                                        00357900
      LAMDA = 2                                                         00358000
      IF ( NCOL.EQ.1 ) LAMDA = 1                                        00358100
      IF (LATYPE.EQ.5.OR.LATYPE.EQ.6) IREF=-1                           00358200
      IF (LATYPE.EQ.5.OR.LATYPE.EQ.6) GO TO 300                         00358300
C                IF NONE SPECIFIED, LEAVE ROUTINE                       00358400
      IF ( ISTOP.LT.1.AND.(IPRINT/2)*2.EQ.IPRINT) WRITE(6,206)          00358500
      IF ( ISTOP.LT.1 ) GO TO 300                                       00358600
C                B ENTRANCE PUPIL                                       00358700
C                B LOCATOR                                              00358800
      IF ( FMASK(ISTOP).GT.ZERO ) GO TO 220                             00358900
      IF ((IPRINT/2)*2.EQ.IPRINT) WRITE(6,201)                          00359000
      GO TO 300                                                         00359100
  220 AB=ZERO                                                           00359200
      ABB=FMASK(ISTOP)                                                  00359300
      IF (ISTOP.EQ.1) GO TO 230                                         00359400
      SGN1 = FREF0                                                      00359500
      L=ISTOP-1                                                         00359600
      DO 225 I=1,L                                                      00359700
        IF (FREF(I).EQ.-ONE) SGN1 = -SGN1                               00359800
  225 CONTINUE                                                          00359900
      SGNAP = SGN1*FREF(ISTOP)                                          00360000
      TM1=.1D0                                                          00360100
      TM1B=TM1                                                          00360200
      GO TO 240                                                         00360300
  230 TM1=.1D0                                                          00360400
      TM1B=TM1                                                          00360500
      SGNAP = FREF0 * FREF(1)                                           00360600
      SGN1 = FREF0                                                      00360700
      GO TO 260                                                         00360800
C                BACK TRACE (PARAXIALLY) A RAY THROUGH THE SYSTEM       00360900
  240 DO 250 I=1,L                                                      00361000
        M=ISTOP-I                                                       00361100
        IF ((IPRINT/2)*2.NE.IPRINT) GO TO 245                           00361200
C                IF TILTED OR DECENTERED SURFACE BETWEEN APERTURE STOP  00361300
C                AND ENTRANCE PUPIL, TELL USER                          00361400
        IF (TILTX(M).NE.ZERO .OR. TILTY(M).NE.ZERO .OR. TILTZ(M).NE.ZERO00361500
     $     .OR. XDISP(M).NE.ZERO .OR. YDISP(M).NE.ZERO ) WRITE(6,202)   00361600
  245   SGN2 = SGN1                                                     00361700
        IF (FREF(M).EQ.-ONE) SGN2 = -SGN1                               00361800
        IF (M.EQ.1) RN1 = OBJN(LAMDA)*SGN2                              00361900
        IF (M.GT.1) RN1 = FN(M-1,LAMDA)*SGN2                            00362000
        RN2  = FN(M,LAMDA)*SGN1                                         00362100
        GNU  = RN2/RN1                                                  00362200
        ABB  = ABB + T(M)*TM1B                                          00362300
        AB   = AB + T(M)*TM1                                            00362400
        TM1B = TM1B + ABB*C(M)*(ONE-GNU)                                00362500
        TM1  = TM1 + AB*C(M)*(ONE-GNU)                                  00362600
        SGN1 = SGN2                                                     00362700
  250 CONTINUE                                                          00362800
C                D IS INTERSECTION OF RAY AND AXIS WITH RESPECT TO      00362900
C                SURFACE 1 COORD SYSTEM (D = 0 IF ISTOP =1)             00363000
  260 TM7=-AB/TM1                                                       00363100
      D = TM7                                                           00363200
      RHO=DABS(ABB+TM7*TM1B)                                            00363300
      ENPUPR = RHO                                                      00363400
      ENPUPL = D                                                        00363500
C             LOCATE AND SIZE PARAXIAL EXIT PUPIL; PRINT INFORMATION    00363600
      AB=ZERO                                                           00363700
      ABB=FMASK(ISTOP)                                                  00363800
      L=ISTOP+1                                                         00363900
      SGN1 = SGNAP                                                      00364000
      TM1=.1D0                                                          00364100
      TM1B=TM1                                                          00364200
      DO 290 I=L,NSURF                                                  00364300
        IF ((IPRINT/2)*2.NE.IPRINT) GO TO 285                           00364400
        IF (TILTX(I).NE.ZERO .OR. TILTY(I).NE.ZERO .OR. TILTZ(I).NE.ZERO00364500
     $     .OR. XDISP(I).NE.ZERO .OR. YDISP(I).NE.ZERO ) WRITE(6,202)   00364600
  285   SGN2 = SGN1                                                     00364700
        IF (FREF(I).EQ.-ONE) SGN2 = -SGN1                               00364800
        RN1  = FN(I,LAMDA)*SGN1                                         00364900
        RN2  = FN(I-1,LAMDA)*SGN1                                       00365000
        GNU  = RN2/RN1                                                  00365100
        ABB  = ABB + T(I-1)*TM1B                                        00365200
        AB   = AB + T(I-1)*TM1                                          00365300
        TM1B = TM1B + ABB*C(I)*(GNU-ONE)                                00365400
        TM1  = TM1 + AB*C(I)*(GNU-ONE)                                  00365500
        SGN1 = SGN2                                                     00365600
  290 CONTINUE                                                          00365700
      TM7=-AB*FN(NSURF,LAMDA)/TM1                                       00365800
      TM8=DABS(ABB+TM7*TM1B/FN(NSURF,LAMDA))                            00365900
      EXPUPR = TM8                                                      00366000
      EXPUPL = TM7                                                      00366100
C              END OF EXIT PUPIL LOCATION                               00366200
C                                                                       00366300
  300 HYMAX=HYINIT+(RNOBJ-ONE)*HYDEL                                    00366400
      HYMAX=-DTAN(HYMAX*PI/180.)*(S-D)                                  00366500
      HXMAX=HXINIT+(RNOBJ-ONE)*HXDEL                                    00366600
      HXMAX=-DTAN(HXMAX*PI/180.)*(S-D)                                  00366700
      FXNU=RHO/(S-D)                                                    00366800
      FXY=FXNU*(S-D)                                                    00366900
      FBNU = -HYMAX/(S-D)                                               00367000
      FBY=ZERO                                                          00367100
C                END EP LOCATOR                                         00367200
C                INITIALIZE SYSTEM                                      00367300
C                XSUM, YSUM ARE ACCUMULATORS FOR AVERAGES FOR           00367400
C                EACH IMAGE PLANE COORD                                 00367500
C                XSUMSQ, YSUMSQ ARE USED FOR RMS CALCULATIONS           00367600
  305 ITEMP=FPLANE                                                      00367700
      IF ((IPRINT/2)*2.NE.IPRINT) GO TO 308                             00367800
C                CHECK IMAGE PLANE NUMBERING                            00367900
      IF ( NPLANE+ITEMP.LT.0 .OR. ITEMP.GT.0 .OR. NPLANE.LE.0 )         00368000
     $     WRITE(6,203)                                                 00368100
  308 IF (NPLANE.LE.0) GO TO 320                                        00368200
      DO 310 I=1,NPLANE                                                 00368300
        XSUM(I)=ZERO                                                    00368400
        YSUM(I)=ZERO                                                    00368500
        XSUMSQ(I)=ZERO                                                  00368600
        YSUMSQ(I)=ZERO                                                  00368700
  310 CONTINUE                                                          00368800
C                NIMG = NUMBER OF PRIME IMAGE PLANE                     00368900
  320 NIMG=1-(FPLANE)                                                   00369000
      TEMP=1-NIMG                                                       00369100
      PRINAN=ZERO                                                       00369200
      IF ((IPRINT/2)*2.NE.IPRINT) GO TO 325                             00369300
C                ALARM IF FIRST PLANE NO. NOT INTEGER                   00369400
      IF ( TEMP.NE.FPLANE ) WRITE(6,204)                                00369500
  325 NMISS=0                                                           00369600
      NREFL=0                                                           00369700
      NVIGN=0                                                           00369800
      HYLAST=-DTAN(HYINIT*PI/180.)*(S-D)                                00369900
      HXLAST=-DTAN(HXINIT*PI/180.)*(S-D)                                00370000
      LAMDA=ICOL(1)                                                     00370100
C             VARIABLE           OPTION                                 00370200
C             OPTION A   PRINTS PRIME IMAGE COORD ONLY                  00370300
C             OPTION B   PRINTS COORD AND COSINES IN EP AND IMAGE       00370400
C             OPTION C   PRINTS COORD FOR SURFACES                      00370500
C             OPTION D   CAUSES PRESCRIPTION MATRIX PRINT               00370600
C             OPTION E   PRINTS RED TABLES                              00370700
C             OPTION F   PRINTS MTF TABLES                              00370800
C             OPTION G   CAUSES ANALYSIS FOR EACH HEIGHT, COLOR         00370900
      OPTNA=(IPRINT/8)-(IPRINT/16)*2                                    00371000
      OPTNB=(IPRINT/2)-(IPRINT/4)*2                                     00371100
      OPTNC=(IPRINT/4)-(IPRINT/8)*2                                     00371200
      OPTND=IPRINT-(IPRINT/2)*2                                         00371300
      OPTNE=(IPRINT/16)-(IPRINT/32)*2                                   00371400
      OPTNF=(IPRINT/32)-(IPRINT/64)*2                                   00371500
      OPTNG=1                                                           00371600
C                                                                       00371700
C                IF NO VALID CODE, BYPASS ROUTINE                       00371800
      IF ( IPLTPR.GT.15 .OR. IPLTPR.LT.0 ) IPLTPR = 0                   00371900
C                EXTRACT SWITCHES                                       00372000
C                IOPA - SPOT PLOT (UNITS) SWITCH                        00372100
C                IOPB - RADIAL ENERGY DIST PLOT SW                      00372200
C                IOPC - MODULATION TRANSFER FUNCTION PLOT SW            00372300
      IOPA = IPLTPR - (IPLTPR/2)*2                                      00372400
      IOPB = (IPLTPR/4) - (IPLTPR/8)*2                                  00372500
      IOPC = (IPLTPR/8) - (IPLTPR/16)*2                                 00372600
C                                                                       00372700
C             PRINT PRESCRIPTION MATRIX                                 00372800
      IF (OPTND.EQ.0) GO TO 327                                         00372900
      CALL PREPRT                                                       00373000
      FXY=FFXY                                                          00373100
      FXNU=FFXNU                                                        00373200
      FBY=FFBY                                                          00373300
      FBNU=FFBNU                                                        00373400
      GO TO 1910                                                        00373500
C                SET OPTIONB IF OPTIONC                                 00373600
  327 IF (OPTNC.NE.0) OPTNB=1                                           00373700
C                RESET OPTIONB AND OPTIONC IF OPTIONA                   00373800
      OPTNB=-OPTNB*(OPTNA-1)                                            00373900
      OPTNC=-OPTNC*(OPTNA-1)                                            00374000
C                                                                       00374100
      IF ( ISRF.NE.IZERO ) CALL SRFSAG                                  00374200
      IF (LATYPE.NE.5.AND.LATYPE.NE.6) GO TO 328                        00374300
        D=0                                                             00374400
        GO TO 525                                                       00374500
C                                                                       00374600
C                B LATTICE                                              00374700
C                B GENERATION                                           00374800
C                LATYPE =1 IF SINGLE RAY                                00374900
C                       =2 IF POLAR LATTICE                             00375000
C                       =3 IF RECTANGULAR LATTICE                       00375100
C                IF IREF>1 GENERATE RAY COORDS                          00375200
C                   AT REFERENCE SURFACE AS WELL AS                     00375300
C                   AT ENTRANCEPUPIL                                    00375400
C                FAKEC(IREF)  =-1  IF ELLIPTICAL MASK                   00375500
C                             = 0  IF CIRCULAR MASK                     00375600
C                             = 1  IF RECTANGULAR MASK                  00375700
  328 GO TO (330,340,400,470,525,525,392), LATYPE                       00375800
C                C ONE RAY                                              00375900
C                C LATTICE                                              00376000
C                SET UP SINGLE RAY, GO FIND COSINES                     00376100
  330 XW(1)=RHO*CLTRA(1)                                                00376200
      YW(1)=RHO*CLTRA(2)                                                00376300
      IF (IREF.LE.IZERO) GO TO 333                                      00376400
C           CIRCULAR MASK                                               00376500
      XWN(1)=FMASK(IREF)*CLTRA(1)                                       00376600
      YWN(1)=FMASK(IREF)*CLTRA(2)                                       00376700
      IF (FAKEC(IREF).EQ.0) GO TO 333                                   00376800
C           RECTANGULAR OR ELLIPTICAL MASK                              00376900
      XWN(1)=XMX(IREF)*CLTRA(1)                                         00377000
      YWN(1)=YMX(IREF)*CLTRA(2)                                         00377100
  333 NUMPTS=1                                                          00377200
      GO TO 480                                                         00377300
C                CC END ONE RAY LATTICE                                 00377400
C                C POLAR                                                00377500
C                C LATTICE                                              00377600
C                SET UP POLAR LATTICE                                   00377700
C                ANULI = NUMBER OF ANNULI                               00377800
C                SECTRS = NUMBER OF SECTORS                             00377900
C                XW = X COORD OF POINT IN 1/2 CIRCLE OF POINTS          00378000
C                YW = Y COORD OF POINT IN 1/2 CIRCLE OF POINTS          00378100
  340 ANULI=CLTRA(1)                                                    00378200
      SECTRS=CLTRA(2)                                                   00378300
      ITATS=ANULI*SECTRS                                                00378400
      IF ( ITATS.EQ.0 ) GO TO 370                                       00378500
C                TA*TA/2 POINTS ARE CREATED                             00378600
      LTATS=ITATS/2                                                     00378700
      IF (LTATS.LE.LIMIT) GO TO 360                                     00378800
C                ALARM IF POINTS O-FLOW                                 00378900
  350 WRITE(6,205)                                                      00379000
      GO TO 1890                                                        00379100
  360 ITS2=SECTRS/2                                                     00379200
      IF (ITS2*2.EQ.SECTRS) GO TO 380                                   00379300
C                ALARM IF ASSYMMETRIC                                   00379400
  370 WRITE(6,205)                                                      00379500
      GO TO 1890                                                        00379600
C                CALCULATE POINTS COORD                                 00379700
  380 PIOVTS=PI/SECTRS                                                  00379800
      ATA=ANULI                                                         00379900
      TEMP=FOUR*DSIN(PIOVTS/TWO)/(THREE*PIOVTS)                         00380000
      K=0                                                               00380100
      DO 390 I=1,ANULI                                                  00380200
        AI=I                                                            00380300
        RI=DSQRT(AI/ATA)                                                00380400
        RIM1=DSQRT((AI-ONE)/ATA)                                        00380500
        RHOBAR=TEMP*(RI**3-RIM1**3)/(RI*RI-RIM1*RIM1)                   00380600
        IF (IREF.LE.0) GO TO 385                                        00380700
        IF (FAKEC(IREF))  381,382,383                                   00380800
C             SCALE RHOBAR TO REFERENCE SURFACE                         00380900
C             STORE RESULT IN REFBAR                                    00381000
C                                                                       00381100
C             ELLIPTICAL MASK                                           00381200
  381   IF (XMX(IREF).GE.YMX(IREF)) ELIPRD=XMX(IREF)                    00381300
        IF (XMX(IREF).LT.YMX(IREF)) ELIPRD=YMX(IREF)                    00381400
        REFBAR=ELIPRD*RHOBAR                                            00381500
        GO TO 385                                                       00381600
C             CIRCULAR MASK                                             00381700
  382   REFBAR=FMASK(IREF)*RHOBAR                                       00381800
        GO TO 385                                                       00381900
C             RECTANGULAR MASK                                          00382000
  383   REFBAR=DSQRT(XMX(IREF)*XMX(IREF)+YMX(IREF)*YMX(IREF))*RHOBAR    00382100
C             SCALE RHOBAR TO ENTRANCEPUPIL                             00382200
C             STORE RESULT IN RHOBAR                                    00382300
  385   RHOBAR=RHO*RHOBAR                                               00382400
        DO 390 J=1,ITS2                                                 00382500
          ARG=PIOVTS*(TWO*J-ONE)-PI/TWO                                 00382600
          K=K+1                                                         00382700
          XW(K)=RHOBAR*DCOS(ARG)                                        00382800
          YW(K)=RHOBAR*DSIN(ARG)                                        00382900
          IF (IREF.LE.IZERO) GO TO 390                                  00383000
          XWN(K)=REFBAR*DCOS(ARG)                                       00383100
          YWN(K)=REFBAR*DSIN(ARG)                                       00383200
  390 CONTINUE                                                          00383300
C                GO CALCULATE COSINES                                   00383400
      NUMPTS=K                                                          00383500
      GO TO 480                                                         00383600
C                CC END POLAR LATTICE                                   00383700
C                RIM LATTICE ROUTINE                                    00383800
C                NUMPTS = NUMBER POINTS TOTAL                           00383900
C                DTHETA = ANGULAR INCREMENT                             00384000
C                RIMANG = CURRENT ANGLE                                 00384100
C                J = NUMBER POINTS THUSFAR MADE                         00384200
  392 NUMPTS=CLTRA(1)                                                   00384300
      DTHETA=CLTRA(2)                                                   00384400
      IF (NUMPTS.LE.0.OR.NUMPTS.GT.LIMIT) GO TO 350                     00384500
      RIMANG=-PI/2.D0                                                   00384600
      J=0                                                               00384700
  393 J=J+1                                                             00384800
      RIMANG=RIMANG+DTHETA                                              00384900
      XW(J)=DCOS(J*RIMANG)                                              00385000
      YW(J)=DSIN(J*RIMANG)                                              00385100
      IF (J.GT.LIMIT) GO TO 350                                         00385200
      IF (RIMANG+DTHETA.LE.PI/2.D0) GO TO 393                           00385300
      NUMPTS=J                                                          00385400
      DO 399 I=1,NUMPTS                                                 00385500
        XWIHLD=XW(I)                                                    00385600
        YWIHLD=YW(I)                                                    00385700
C                SCALE POINTS AT ENTRANCEPUPIL                          00385800
        XW(I)=RHO*XW(I)                                                 00385900
        YW(I)=RHO*YW(I)                                                 00386000
        IF (IREF.LE.IZERO) GO TO 399                                    00386100
C                SCALE POINTS AT REFERENCE SURFACE                      00386200
        IF (FAKEC(IREF)) 396,397,398                                    00386300
C                ELLIPTICAL MASK                                        00386400
  396  IF (XMX(IREF).GE.YMX(IREF)) RDWN=XMX(IREF)                       00386500
       IF (XMX(IREF).LT.YMX(IREF)) RDWN=YMX(IREF)                       00386600
       XWN(IREF)=RDWN*XWIHLD                                            00386700
       YWN(IREF)=RDWN*YWIHLD                                            00386800
       GO TO 399                                                        00386900
C                CIRCULAR MASK                                          00387000
  397  XWN(I)=FMASK(IREF)*XWIHLD                                        00387100
       YWN(I)=FMASK(IREF)*YWIHLD                                        00387200
       GO TO 399                                                        00387300
C                RECTANGULAR OR ELLIPTICAL MASK                         00387400
  398  XWN(I)=XMX(IREF)*XWIHLD                                          00387500
       YWN(I)=YMX(IREF)*YWIHLD                                          00387600
  399 CONTINUE                                                          00387700
      GO TO 480                                                         00387800
C                CC END RIM LATTICE                                     00387900
C                RECTANGULAR LATTICE ROUTINE                            00388000
C                NUMPTS = NUMBER POINTS TOTAL                           00388100
C                DELY = Y INCREMENT                                     00388200
C                NUMCOL = NUM POINTS THIS COL                           00388300
C                IND = FW INDEX OF NEXT COLUMN SET                      00388400
C                NSUM = NUMBER POINTS THUSFAR MADE                      00388500
  400 NUMPTS=CLTRA(1)                                                   00388600
      DELY=CLTRA(2)                                                     00388700
      NUMCOL=CLTRA(3)                                                   00388800
      XW(1)=CLTRA(4)                                                    00388900
      YW(1)=CLTRA(5)                                                    00389000
      IND=6                                                             00389100
      K=2                                                               00389200
      NSUM=NUMCOL                                                       00389300
      IF (NUMPTS.LE.0) GO TO 350                                        00389400
      IF (NUMPTS.GT.LIMIT) GO TO 350                                    00389500
  410 IF (NSUM.GT.LIMIT) GO TO 350                                      00389600
C                THIS DO LOOP CREATES ALL POINTS ABOVE FIRST FOR EACH   00389700
C                COLUMN                                                 00389800
      IF (NUMCOL.LT.2) GO TO 430                                        00389900
      DO 420 I=2,NUMCOL                                                 00390000
        XW(K)=XW(K-1)                                                   00390100
        YW(K)=YW(K-1)+DELY                                              00390200
        K=K+1                                                           00390300
  420 CONTINUE                                                          00390400
C                IS LATTICE GENERATED                                   00390500
  430 IF (NSUM-NUMPTS) 440,450,370                                      00390600
C                NO, START NEXT COLUMN                                  00390700
  440 NUMCOL=CLTRA(IND)                                                 00390800
      XW(K)=CLTRA(IND+1)                                                00390900
      YW(K)=CLTRA(IND+2)                                                00391000
      IND=IND+3                                                         00391100
      IF (IND.GT.298) GO TO 350                                         00391200
      NSUM=NSUM+NUMCOL                                                  00391300
      K=K+1                                                             00391400
      GO TO 410                                                         00391500
C                THROUGH BUILDING RECT LATTICE, SCALE POINTS            00391600
  450 DO 460 I=1,NUMPTS                                                 00391700
        XWIHLD=XW(I)                                                    00391800
        YWIHLD=YW(I)                                                    00391900
C                SCALE POINTS AT ENTRANCEPUPIL                          00392000
        XW(I)=RHO*XW(I)                                                 00392100
        YW(I)=RHO*YW(I)                                                 00392200
        IF (IREF.LE.IZERO) GO TO 460                                    00392300
C                SCALE POINTS AT REFERENCE SURFACE                      00392400
        IF (FAKEC(IREF)) 458,457,458                                    00392500
C                CIRCULAR MASK                                          00392600
  457  XWN(I)=FMASK(IREF)*XWIHLD                                        00392700
       YWN(I)=FMASK(IREF)*YWIHLD                                        00392800
       GO TO 460                                                        00392900
C                RECTANGULAR OR ELLIPTICAL MASK                         00393000
  458  XWN(I)=XMX(IREF)*XWIHLD                                          00393100
       YWN(I)=YMX(IREF)*YWIHLD                                          00393200
  460 CONTINUE                                                          00393300
      GO TO 480                                                         00393400
C                CC END COLUMN LATTICE                                  00393500
C                C RAY                                                  00393600
C                C GENERATION                                           00393700
  470 REWIND 40                                                         00393800
      REWIND 50                                                         00393900
      CALL FINRAY (NFOC)                                                00394000
      GO TO 520                                                         00394100
C                REWIND LATTICE TAPES                                   00394200
  480 REWIND 40                                                         00394300
      REWIND 50                                                         00394400
C                CALCULATE DIRECTIONAL COSINES FOR EACH POINT IN THE    00394500
C                LATTICE AND WRITE THEM ON TAPE                         00394600
      Z=ZERO                                                            00394700
      DZ=S-D                                                            00394800
      NOBJ=RNOBJ                                                        00394900
      IF (NUMPTS.LE.0) GO TO 350                                        00395000
      IF (NOBJ.LE.0) GO TO 1890                                         00395100
      IF (DABS(DZ).LT.EPS1) GO TO 1890                                  00395200
C                                                                       00395300
      I=0                                                               00395400
  490 I=I+1                                                             00395500
      IF (I.GT.NOBJ) GO TO 520                                          00395600
      IF (NFOC.GT.0) I=NFOC                                             00395700
C                HXANG,HYANG ARE OBJECT POINT IN DEGREES                00395800
      HXANG=HXINIT+(I-1)*HXDEL                                          00395900
      HYANG=HYINIT+(I-1)*HYDEL                                          00396000
C                HX,HY ARE OBJECT POINT IN LINEAR DIMENSIONS            00396100
      HX=-DTAN(HXANG*PI/180.)*DZ                                        00396200
      HY=-DTAN(HYANG*PI/180.)*DZ                                        00396300
      SGN=ONE                                                           00396400
  500 CONTINUE                                                          00396500
      DO 510 J=1,NUMPTS                                                 00396600
        XP=SGN*XW(J)                                                    00396700
        DX=XP-HX                                                        00396800
        DY=YW(J)-HY                                                     00396900
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00397000
        QX=DX/DENOM                                                     00397100
        QY=DY/DENOM                                                     00397200
        QZ=DZ/DENOM                                                     00397300
C            DESX,DESY = DESIRED RAY COORDS AT REFERENCE SURFACE        00397400
        DESX=IZERO                                                      00397500
        DESY=IZERO                                                      00397600
        IF (IREF.GT.IZERO) DESX=SGN*XWN(J)                              00397700
        IF (IREF.GT.IZERO) DESY=YWN(J)                                  00397800
        WRITE (40) XP,YW(J),Z,QX,QY,QZ,HY,HX,DESX,DESY                  00397900
  510 CONTINUE                                                          00398000
      SGN=-SGN                                                          00398100
      IF (IMODE.EQ.1 .AND. SGN.EQ.-ONE) GO TO 500                       00398200
      IF (NFOC.GT.0) GO TO 520                                          00398300
      GO TO 490                                                         00398400
C                                                                       00398500
  520 FSTP=-TWO                                                         00398600
      WRITE (40) (FSTP,I=1,10)                                          00398700
      END FILE 40                                                       00398800
      IEOF=2                                                            00398900
C                CC END RAY GENERATION                                  00399000
C                BB END LATTICE PROCESSING                              00399100
C                AA END INITIALIZATION                                  00399200
C                A COLOR PROCESSING                                     00399300
C                EXECUTE COMPLETE TRACE FOR EACH COLOR                  00399400
C                LAMDA = COLOR NUMBER THIS TRIP                         00399500
C                NTIMES = NUMBER RAYS THROUGH SYSTEM                    00399600
C                NRAY = NUMBER OF THIS RAY (SEQUENCE)                   00399700
  525 IF (NCOL.EQ.0) GO TO 1890                                         00399800
      INDX=1                                                            00399900
      INDY=1                                                            00400000
      NDCOL=NCOL                                                        00400100
      IF (IMODE.NE.0) GO TO 530                                         00400200
      INDX=0                                                            00400300
      INDY=2                                                            00400400
  530 IF (LFOC.GT.0) GO TO 540                                          00400500
      GO TO 550                                                         00400600
  540 LAMDA=ICOL(LFOC)                                                  00400700
      NDCOL=1                                                           00400800
  550 DO 1880 LAMDX=1,NDCOL                                             00400900
C           X2DEC,Y2DEC = X,Y DISPLACEMENTS OF CHIEF RAY                00401000
C                 AT ENTPUP WHEN ITERATED TO GO THROUGH                 00401100
C                 ORIGIN OF REFERENCE SURFACE                           00401200
C           KFLAG  = 0  SINGLE SPOT PLOT OR NO SPOT PLOT                00401300
C                  = 1  MULTIPLE SPOT PLOT                              00401400
C           IJK    =    NUMBER OF RAYS IN MULTIPLE SPOT PLOT            00401500
        X2DEC=0                                                         00401600
        Y2DEC=0                                                         00401700
        IJK=0                                                           00401800
        KFLAG=0                                                         00401900
        IF (LFOC.GT.0) GO TO 560                                        00402000
        LAMDA=ICOL(LAMDX)                                               00402100
        IF (IREF.LE.1) CALL HEADIN(LAMDA)                               00402200
  560   NTHRU=0                                                         00402300
        NRAY=0                                                          00402400
        REWIND 40                                                       00402500
        REWIND 50                                                       00402600
C             HEAD FOR PRIME IMAGE ONLY PRINT                           00402700
        IF (OPTNA.NE.0.AND.IEOF.NE.1) WRITE(6,30)                       00402800
C                B RAY PROCESSING                                       00402900
C                INPUT ONE RAY                                          00403000
  570   IF (LATYPE.NE.5) GO TO 571                                      00403100
        READ(20,212) ORIGX,ORIGY,PZ,(QT(I),I=1,3),THISHY,THISHX         00403200
        GO TO 573                                                       00403300
  571   IF (LATYPE.NE.6) GO TO 572                                      00403400
        READ(20,212) ORIGX,ORIGY,PZ,(QT(I),I=1,3),THISHY,THISHX         00403500
        THISHY=0                                                        00403600
        THISHX=0                                                        00403700
        GO TO 573                                                       00403800
  572   IF (IREF.GE.IONE.OR.IREF.EQ.-1)                                 00403900
     $  READ (40) ORIGX,ORIGY,PZ,(QT(I),I=1,3),THISHY,THISHX,DESX,DESY  00404000
        IF (NRAY.GE.1.AND.IREF.GT.0) ORIGX=ORIGX+X2DEC                  00404100
        IF (NRAY.GE.1.AND.IREF.GT.0) ORIGY=ORIGY+Y2DEC                  00404200
        ZHOLD=PZ                                                        00404300
        QXHOLD=QX                                                       00404400
        QYHOLD=QY                                                       00404500
        QZHOLD=QZ                                                       00404600
        IF (IREF.EQ.IZERO)                                              00404700
     $  READ (50) ORIGX,ORIGY,PZ,(QT(I),I=1,3),THISHY,THISHX,DESX,DESY  00404800
  573   PX=ORIGX                                                        00404900
        PY=ORIGY                                                        00405000
        NITRAT=0                                                        00405100
        ITREAD=IZERO                                                    00405200
        IWHICH=IZERO                                                    00405300
  575   IF (IREF.GT.IZERO) ITREAD=IONE                                  00405400
        IF (IREF.GT.IZERO) IWHICH=IONE                                  00405500
        IEOF=2                                                          00405600
C                CHECK FOR LAST RAY FLAG                                00405700
        IF (QT(1).EQ.-TWO) IEOF=1                                       00405800
        IF (IEOF.EQ.1.AND.KFLAG.EQ.1) GO TO 1890                        00405900
        IF (IEOF.EQ.1.AND.ITREAD.EQ.1) GO TO 1880                       00406000
C                END OF COLOR                                           00406100
        IF (OPTNG.NE.0.AND.IEOF.EQ.1) GO TO 1350                        00406200
C                DUMMY BRANCH IF EOF ONLY                               00406300
        IF (IEOF.EQ.1) GO TO 1880                                       00406400
C                END OF RAYS FOR THIS HEIGHT                            00406500
        IF ((THISHY.NE.HYLAST.OR.THISHX.NE.HXLAST).AND.KFLAG.EQ.1)      00406600
     $     GO TO 1360                                                   00406700
        IF ((THISHY.NE.HYLAST.OR.THISHX.NE.HXLAST).AND.OPTNG.NE.0       00406800
     $     .AND.IREF.GT.IZERO) GO TO 1360                               00406900
        IF ( (THISHY.NE.HYLAST.OR.THISHX.NE.HXLAST) .AND. OPTNG.NE.0 )  00407000
     $     GO TO 1350                                                   00407100
        IF (KFLAG.EQ.1) GO TO 570                                       00407200
C                                                                       00407300
C                SAVE ALL COORDS, TRACE CHIEF RAY                       00407400
  580   IF (NRAY.GT.0.OR.IREF.LE.0.OR.KFLAG.EQ.1)                       00407500
     $     GO TO 582                                                    00407600
C             GIBRSH(1..8) STORE ALL DATA FROM RECORD 1                 00407700
C                  OF UNIT 40 UNTIL CHIEF RAY ITERATION IS OVER         00407800
        GIBRSH(1)=ORIGX                                                 00407900
        GIBRSH(2)=ORIGY                                                 00408000
        GIBRSH(3)=PZ                                                    00408100
        GIBRSH(4)=QX                                                    00408200
        GIBRSH(5)=QY                                                    00408300
        GIBRSH(6)=QZ                                                    00408400
        GIBRSH(7)=DESX                                                  00408500
        GIBRSH(8)=DESY                                                  00408600
        ORIGX=0                                                         00408700
        ORIGY=0                                                         00408800
        DESX=0                                                          00408900
        DESY=0                                                          00409000
        PZ=0                                                            00409100
        ZHOLD=PZ                                                        00409200
        QR=DSQRT(THISHX*THISHX+THISHY*THISHY+DZ*DZ)                     00409300
        QX=-THISHX/QR                                                   00409400
        QY=-THISHY/QR                                                   00409500
        QZ=DZ/QR                                                        00409600
        QXHOLD=QX                                                       00409700
        QYHOLD=QY                                                       00409800
        QZHOLD=QZ                                                       00409900
        PX=ORIGX                                                        00410000
        PY=ORIGY                                                        00410100
        NITRAT=0                                                        00410200
        ITREAD=1                                                        00410300
        IWHICH=1                                                        00410400
        IEOF=2                                                          00410500
        GO TO 585                                                       00410600
C                                                                       00410700
C                REASSIGN COORDS AFTER REFERENCE SURF ITERATIONS        00410800
  581   ORIGX=GIBRSH(1)+X2DEC                                           00410900
        ORIGY=GIBRSH(2)+Y2DEC                                           00411000
        PZ=GIBRSH(3)                                                    00411100
        QX=GIBRSH(4)                                                    00411200
        QY=GIBRSH(5)                                                    00411300
        QZ=GIBRSH(6)                                                    00411400
        DESX=GIBRSH(7)                                                  00411500
        DESY=GIBRSH(8)                                                  00411600
        PX=ORIGX                                                        00411700
        PY=ORIGY                                                        00411800
        ZHOLD=PZ                                                        00411900
        QXHOLD=QX                                                       00412000
        QYHOLD=QY                                                       00412100
        QZHOLD=QZ                                                       00412200
C                UPDATE RAY NUMBER                                      00412300
  582   NRAY=NRAY+1                                                     00412400
C                PN = PREVIOUS SURFACE INDEX OF REF                     00412500
C                PT = DIST FROM LAST SURF                               00412600
  585   PN=OBJN(LAMDA)                                                  00412700
        PT=D                                                            00412800
        IF (ITREAD.GT.IZERO) GO TO 605                                  00412900
        IF (OPTNB) 590,600,590                                          00413000
C             HEAD SURFACE PRINTOUT AND PRINT EP INFO                   00413100
  590   IF (IREF.GT.0) GO TO 600                                        00413200
        WRITE(6,10) NRAY                                                00413300
        WRITE(6,130) PX,PY,PZ,QT                                        00413400
C                C TRACING SURFACE BY SURFACE                           00413500
C                START TRACE LOOP FOR NSURF SURFACES                    00413600
C             TEST IF SURF(I) IS IMAGE SURFACE                          00413700
C             IF YES, PRINT/PLOT X AND Y                                00413800
  600   IF (FAKEA.GT.ZERO) GO TO 610                                    00413900
        GO TO 620                                                       00414000
  605   NSURF=IREF                                                      00414100
        GO TO 620                                                       00414200
  610   NSURF=FAKEA                                                     00414300
        TEMP=ZERO                                                       00414400
        T(NSURF)=ZERO                                                   00414500
        DELIMP=ZERO                                                     00414600
        FPLANE=ZERO                                                     00414700
        NPLANE=1                                                        00414800
        NIMG=1                                                          00414900
  620   DO 1200 I=1,NSURF                                               00415000
          TM1=FN(I,LAMDA)                                               00415100
          TM2=PN                                                        00415200
          TM3=C(I)                                                      00415300
          ISW=2                                                         00415400
          NTOR=TOR(I)+ONE                                               00415500
C              NOW NTOR = 1 FOR CONIC OR POLYNOMIAL                     00415600
C                  NTOR = 2 FOR TORIC                                   00415700
C                  NTOR = 4 FOR BILATERAL SYMMETRIC SURFACE             00415800
          GO TO (640,630,640,640), NTOR                                 00415900
  630     ISW=3                                                         00416000
          GO TO 670                                                     00416100
  640     DO 650 IA=1,4                                                 00416200
            IF (COEF(I,IA)) 660,650,660                                 00416300
  650     CONTINUE                                                      00416400
          GO TO 670                                                     00416500
C                                                                       00416600
C                ISW = 1 IF POLYNOMIAL SURFACE                          00416700
C                ISW = 2 IF CONIC SURFACE                               00416800
C                ISW = 3 IF TORIC                                       00416900
  660     ISW=1                                                         00417000
C                D TRANSFER EQUATIONS                                   00417100
C                E TRANSFER COORDINATES TO TILTED/DECENTERED            00417200
C                E TANGENT PLANE TO SURFACE                             00417300
  670     DN = (PT-PZ)*QZ - PY*QY - PX*QX                               00417400
          DN1 = DN                                                      00417500
          XT = PX + DN*QX - XDISP(I)                                    00417600
          YT = PY + DN*QY - YDISP(I)                                    00417700
          ZT = PZ + DN*QZ - PT                                          00417800
          DN = ZT                                                       00417900
C                                                                       00418000
C                (XT,YT,DZ) IS INTERSECTION OF RAY WITH CLOSEST POINT TO00418100
C                VERTEX OF SURFACE I, UNTILTED, DECENTERED              00418200
C                                                                       00418300
C                IF ALL TILTS = 0, SKIP TILTING ROUTINE                 00418400
          IF ( DABS(TILTX(I)).EQ.ZERO .AND. DABS(TILTY(I)).EQ.ZERO .AND.00418500
     $         DABS(TILTZ(I)).EQ.ZERO ) GO TO 680                       00418600
C                                                                       00418700
C                CALL ROTM TO CONSTRUCT ROTATION MATRIX                 00418800
          ALPHA = TILTX(I)                                              00418900
          BETA  = TILTY(I)                                              00419000
          GAMMA = TILTZ(I)                                              00419100
C                CALL ROTM TO CONSTRUCT ROTATION MATRIX                 00419200
          CALL ROTM (ALPHA,BETA,GAMMA)                                  00419300
C                CALL MAVEC TO ROTATE COORD, COSINES (SEE EQUIVALENCES) 00419400
          CALL MAVEC (XX,XX)                                            00419500
          CALL MAVEC (QT,QT)                                            00419600
C                AT THIS POINT, COSINES ARE ROTATED AND (XT,YT,ZT) IS   00419700
C                THE POINT OF INTERSEC OF RAY WITH DECENTERED, TILTED   00419800
C                CLOSEST-POINT PLANE (NEW XT, NEW YT, NEW ZT)           00419900
C                                                                       00420000
  680     IF (UFLAG.EQ.FIVE) QZOLD=QZ                                   00420100
C                END OF CLOSEST-POINT TRANSFER                          00420200
C                TRANSFER RAY TO SURFACE (IE FIND COORDINATES OF RAY    00420300
C                ON SURFACE)                                            00420400
          IF (NTOR.EQ.4) ISW = 1                                        00420500
          GO TO (690,690,730), ISW                                      00420600
C                CONIC, SPHERIC, PLANE TRANSFER EQUATIONS               00420700
  690     IF ( C(I).EQ.ZERO .AND. QZ.EQ.ZERO ) GO TO 780                00420800
          DN2 = -ZT/QZ                                                  00420900
          DN = (DN-ZT)/QZ                                               00421000
          IF ( C(I).EQ.ZERO ) GO TO 720                                 00421100
          FTRA = -DSIGN( ONE,QZ*R(I) )                                  00421200
          IF ( DABS(QZ).LT.EPS1 .AND. SIDE(I).EQ.ZERO ) FTRA = ONE      00421300
          IF ( DABS(QZ).LT.EPS1 .AND. SIDE(I).NE.ZERO ) FTRA = SIDE(I)  00421400
          IF ( SIDE(I).NE.ZERO ) FTRA = SIDE(I)                         00421500
          HALPHA = ONE + CONIC(I)*QZ*QZ                                 00421600
          HBETA  = XT*QX + YT*QY + (ONE+CONIC(I))*ZT*QZ - R(I)*QZ       00421700
          HGAMMA = XT*XT + YT*YT + (ONE+CONIC(I))*ZT*ZT - TWO*R(I)*ZT   00421800
          TEMP1  = HBETA*HBETA - HALPHA*HGAMMA                          00421900
C                TEST FOR MISS IF NEG RADICAL                           00422000
          IF ( DABS(TEMP1).LT.EPS1 ) TEMP1 = ZERO                       00422100
          IF ( TEMP1.LT.ZERO ) GO TO 780                                00422200
          TEMP = FTRA * DSQRT(TEMP1)                                    00422300
          IF ( DABS(HGAMMA).LT.EPS1 ) GO TO 700                         00422400
          DENOM = HBETA + TEMP                                          00422500
          IF ( DABS(DENOM).LT.EPS1 ) GO TO 710                          00422600
          DN2 = -HGAMMA/DENOM                                           00422700
          GO TO 720                                                     00422800
  700     IF (DABS(HALPHA).LT.EPS1) GO TO 710                           00422900
          DN2 = (-HBETA + TEMP)/HALPHA                                  00423000
          GO TO 720                                                     00423100
  710     DN2 = ZERO                                                    00423200
  720     IF ( DABS(DN2).LT.EPS2 ) DN2 = ZERO                           00423300
          X = XT + DN2*QX                                               00423400
          Y = YT + DN2*QY                                               00423500
          Z = ZT + DN2*QZ                                               00423600
C                AT THIS POINT, (X,Y,Z) IS THE POINT OF INTERSECTION    00423700
C                WITH THE CONIC (SPHERE, PLANE) IN DECENTERED, TILTED   00423800
C                COORDINATES                                            00423900
C                END OF SPHERICAL-CONIC TRANS EQUATIONS                 00424000
          GO TO (800,880,730), ISW                                      00424100
C                CYLINDER, TORIC TRANSFER EQUATIONS                     00424200
  730     FTRA = -DSIGN( ONE,QZ*R(I) )                                  00424300
          IF ( DABS(QZ).LT.EPS1 .AND. SIDE(I).EQ.ZERO ) FTRA = ONE      00424400
          IF ( DABS(QZ).LT.EPS1 .AND. SIDE(I).NE.ZERO ) FTRA = SIDE(I)  00424500
          IF ( SIDE(I).NE.ZERO ) FTRA = SIDE(I)                         00424600
          HALPHA = (ONE+CONIC(I))*QZ*QZ + QY*QY                         00424700
          HBETA  = YT*QY + (ONE+CONIC(I))*ZT*QZ -R(I)*QZ                00424800
          HGAMMA = YT*YT + (ONE+CONIC(I))*ZT*ZT - TWO*R(I)*ZT           00424900
          TEMP1  = HBETA*HBETA - HALPHA*HGAMMA                          00425000
C                TEST FOR RAY MISS IF NEGATIVE RADICAL                  00425100
          IF ( DABS(TEMP1).LT.EPS1 ) TEMP1 = ZERO                       00425200
          IF ( TEMP1.LT.ZERO ) GO TO 780                                00425300
          TEMP = FTRA*DSQRT(TEMP1)                                      00425400
          IF ( DABS(HGAMMA).LT.EPS1 ) GO TO 740                         00425500
          DENOM = HBETA + TEMP                                          00425600
          IF ( DABS(DENOM).LT.EPS1 ) GO TO 750                          00425700
          DN2 = -HGAMMA/DENOM                                           00425800
          GO TO 760                                                     00425900
  740     IF (DABS(HALPHA).LT.EPS1) GO TO 750                           00426000
          DN2 = (-HBETA+TEMP)/HALPHA                                    00426100
          GO TO 760                                                     00426200
  750     DN2 = ZERO                                                    00426300
  760     X = XT + DN2*QX                                               00426400
          Y = YT + DN2*QY                                               00426500
          Z = ZT + DN2*QZ                                               00426600
C                AT THIS POINT, (X,Y,Z) IS THE INTERSECTION POINT       00426700
C                OF THE RAY WITH A CYLINDER; NEED TO ITERATE TO         00426800
C                COMPLETE TRANSFER TO TORIC                             00426900
          DN = DN2                                                      00427000
          RNX = ZERO                                                    00427100
          RNY = FTRA*Y                                                  00427200
          RNZ = FTRA*( (ONE+CONIC(I))*Z - R(I) )                        00427300
          DOTNN = RNY*RNY + RNZ*RNZ                                     00427400
          DOTNQ = RNY*QY + RNZ*QZ                                       00427500
          IF ( CX(I).EQ.ZERO ) GO TO 880                                00427600
          CALL SURTOR(I)                                                00427700
          TOR34 = CX(I)/TWO                                             00427800
          TOR32 = TM3*(ONE + CONIC(I))                                  00427900
C                ITERATE TO TORIC                                       00428000
          DO 770 K=1,6                                                  00428100
            TOR1 = TM3*Y*Y                                              00428200
            TOR2 = ONE - TOR32*TOR1                                     00428300
            IF ( TOR2.LE.ZERO ) GO TO 780                               00428400
            TOR3  = DSQRT(TOR2)                                         00428500
            TOR4  = TOR1/(ONE+TOR3)                                     00428600
            TOR2  = TM3*Y/TOR3                                          00428700
            TORF  = Z - TOR34*( X*X + Z*Z ) - TOR4*( ONE - TOR34*TOR4 ) 00428800
            TKS   = -CX(I)*X                                            00428900
            TLS   = TOR2*( CX(I)*TOR4- ONE )                            00429000
            TMS   = ONE - CX(I)*Z                                       00429100
            DN2   = DN2 - TORF/DOTNQ                                    00429200
            X     = XT + QX*DN2                                         00429300
            Y     = YT + QY*DN2                                         00429400
            Z     = QZ*DN2                                              00429500
            DOTNQ = TKS*QX + TLS*QY + TMS*QZ                            00429600
            DOTNN = TKS*TKS + TLS*TLS + TMS*TMS                         00429700
            IF ( DABS(TORF)-EPS1 ) 880,880,770                          00429800
  770     CONTINUE                                                      00429900
          GO TO 880                                                     00430000
C                FF END QUADRIC TRANSFERS                               00430100
C                F RAY MISS ACCUMULATOR                                 00430200
  780     IF (OPTNB.NE.0.AND.IREF.LE.1) WRITE(6,50) I                   00430300
C                RAY MISSED SURFACE IF HERE, COUNT AND GO TO  NEXT RAY  00430400
          IF (NRAY.EQ.0.AND.IREF.GT.1) GO TO 1210                       00430500
          NMISS=NMISS+INDY                                              00430600
          IF (IREF.GT.IONE) GO TO 1209                                  00430700
  790     GO TO 570                                                     00430800
C                FF END MISS MESSAGE                                    00430900
C                F ASPHERIC TRANSFER                                    00431000
  800     NITER=0                                                       00431100
          XND=X                                                         00431200
          YND=Y                                                         00431300
          ZND=Z                                                         00431400
C                 2   2   2                 2   2   2   2               00431500
C                S = X + Y  (ROT. SYMM) OR S = X + Y COS  (BILAT. SYMM) 00431600
  810     IF (NTOR.EQ.1) SSQ=XND*XND+YND*YND                            00431700
          IF (NTOR.EQ.4 .AND. TILTY(I).NE.ZERO ) TILT=TILTY(I)*PI/180.  00431800
          IF (NTOR.EQ.4 .AND. TILTX(I).NE.ZERO ) TILT=TILTX(I)*PI/180.  00431900
          IF (NTOR.EQ.4) SSQ=XND*XND+YND*YND*(ONE-DCOS(TILT)*DCOS(TILT))00432000
C                        2 2      1/2                                   00432100
C                W = (1-C S (1-B))                                      00432200
          W=ONE-TM3*TM3*SSQ*(ONE+CONIC(I))                              00432300
          IF (W) 780,840,820                                            00432400
  820     IF (W-EPS2) 840,830,830                                       00432500
  830     DW=DSQRT(W)                                                   00432600
          W=DW                                                          00432700
  840     NITER=NITER+1                                                 00432800
          RTMP=TM3/(ONE+W)                                              00432900
          DF=ZERO                                                       00433000
          DO 850 IA=1,4                                                 00433100
            IND=5-IA                                                    00433200
            DF=(DF+COEF(I,IND))*SSQ                                     00433300
  850     CONTINUE                                                      00433400
          DF=(DF+RTMP)*SSQ                                              00433500
C                                   2                                   00433600
C                                 CS                4   6   8   10      00433700
C                Z (NEW) = --------------------- +ES +FS +GS +HS        00433800
C                                 2 2      1/2                          00433900
C                          (1+(1-C S (1-B))   )                         00434000
C                DELTA Z = Z(NEW) - Z(LAST)                             00434100
          DF=DF-ZND                                                     00434200
          IF (NTOR.EQ.4) TILT=TILTX(I)*PI/180.                          00434300
          IF (NTOR.EQ.4) DF=DF/DSQRT(ONE-DCOS(TILT)*DCOS(TILT))         00434400
          DL=ZERO                                                       00434500
          DO 860 IA=1,4                                                 00434600
            IND=5-IA                                                    00434700
            HARG=12-2*IA                                                00434800
            DL=(DL+HARG*COEF(I,IND))*SSQ                                00434900
  860     CONTINUE                                                      00435000
          DL=TM3+W*DL                                                   00435100
C                              2    4    6     8                        00435200
C                U = -X(C+W(4ES +6FS +8GS +10HS ))                      00435300
          U=-XND*DL                                                     00435400
C                              2    4    6     8                        00435500
C                V = -Y(C+W(4ES +6FS +8GS +10HS ))                      00435600
          V=-YND*DL                                                     00435700
C                        W*DELTA Z                                      00435800
C                G  = -----------------                                 00435900
C                 0    (Q U +Q V +Q W)                                  00436000
C                        X    Y    Z                                    00436100
          DELA=DF*W/(QX*U+QY*V+QZ*W)                                    00436200
          XND=XND+DELA*QX                                               00436300
          YND=YND+DELA*QY                                               00436400
          ZND=ZND+DELA*QZ                                               00436500
          IF (NITER-MAXIT) 810,870,870                                  00436600
C                 2   2  2  2                                           00436700
C                P = U +V +W                                            00436800
  870     GSQ=U*U+V*V+W*W                                               00436900
C                F = Q U+Q V+Q W                                        00437000
C                     X   Y   Z                                         00437100
          GNMONE=QX*U+QY*V+QZ*W                                         00437200
          DOTNQ=GNMONE                                                  00437300
          X=XND                                                         00437400
          Y=YND                                                         00437500
          Z=ZND                                                         00437600
          DN2=DELA                                                      00437700
C                FF END ASPHERIC TRANSFER                               00437800
C                DD END TRANSFER SECTION                                00437900
C                D VIGNETTE TEST CODING                                 00438000
C                AT THIS POINT (X,Y,Z) IS THE INTERSECTION OF THE       00438100
C                RAY WITH THE ASPHERIC (ACONIC) SURFACE IN DECENTERED   00438200
C                TILTED COORDINATES                                     00438300
C                RAD = RADIUS (DIST FROM SURF VERTEX TO POINT OF        00438400
C                INTERSECTION) SQUARED                                  00438500
  880     IF (FMASK(I)) 890,960,920                                     00438600
C                                                                       00438700
  890     IF (FAKEC(I)) 895,910,900                                     00438800
C                ELLIPTICAL OBSCURATION                                 00438900
  895     XTEMP=(X-XMN(I))/XMX(I)                                       00439000
          YTEMP=(Y-YMN(I))/YMX(I)                                       00439100
          ELIP=(XTEMP*XTEMP)+(YTEMP*YTEMP)                              00439200
          IF (ELIP.LT.1) GO TO 950                                      00439300
          GO TO 960                                                     00439400
C                RECTANGULAR OBSCURATION                                00439500
  900     TEMP=ZERO                                                     00439600
          TEMPR=ZERO                                                    00439700
          IF (X.GT.XMN(I).AND.X.LT.XMX(I)) TEMP=ONE                     00439800
          IF (Y.GT.YMN(I).AND.Y.LT.YMX(I)) TEMPR=ONE                    00439900
          IF (IREF.GT.1) GO TO 960                                      00440000
          IF (TEMP.EQ.ONE.AND.TEMPR.EQ.ONE) GO TO 950                   00440100
          GO TO 960                                                     00440200
C                CIRCULAR OBSCURATION                                   00440300
C                MASK HAS CENTER AT (XMN(II),YMN(I)), RADIUS = FMASK(I) 00440400
  910     RAD=(X-XMN(I))*(X-XMN(I))+(Y-YMN(I))*(Y-YMN(I))               00440500
          TEMP=FMASK(I)*FMASK(I)                                        00440600
          IF (IREF.GT.1) GO TO 960                                      00440700
          IF (RAD-TEMP) 950,960,960                                     00440800
C                                                                       00440900
  920     IF (FAKEC(I)) 925,940,930                                     00441000
C                ELLIPTICAL CLEAR APERTURE                              00441100
  925     XTEMP=(X-XMN(I))/XMX(I)                                       00441200
          YTEMP=(Y-YMN(I))/YMX(I)                                       00441300
          ELIP=(XTEMP*XTEMP)+(YTEMP*YTEMP)                              00441400
          IF (ELIP.GT.1) GO TO 950                                      00441500
          GO TO 960                                                     00441600
C                RECTANGULAR CLEAR APERATURE                            00441700
  930     TEMP=ZERO                                                     00441800
          TEMPR=ZERO                                                    00441900
          IF (X.LT.XMN(I).OR.X.GT.XMX(I)) TEMP=ONE                      00442000
          IF (Y.LT.YMN(I).OR.Y.GT.YMX(I)) TEMPR=ONE                     00442100
          IF (IREF.GT.1) GO TO 960                                      00442200
          IF (TEMP.EQ.ONE.OR.TEMPR.EQ.ONE) GO TO 950                    00442300
          GO TO 960                                                     00442400
C                CIRCULAR CLEAR APERATURE                               00442500
C                MASK HAS CENTER AT (XMN(II),YMN(I)), RADIUS = FMASK(I) 00442600
  940     RAD=(X-XMN(I))*(X-XMN(I))+(Y-YMN(I))*(Y-YMN(I))               00442700
          TEMP=FMASK(I)*FMASK(I)                                        00442800
          IF (IREF.GT.IONE) GO TO 960                                   00442900
          IF (RAD-TEMP) 960,960,950                                     00443000
C                EEEEE  END VIGNETTE ACCOUNTING                         00443100
  950     IF (OPTNB.NE.0) WRITE(6,70) I                                 00443200
C                COUNT VIGNETTE AND GO TO  NEXT RAY                     00443300
          IF (IREF.GT.IONE) GO TO 960                                   00443400
          IF (OPTNB.NE.0.OR.OPTNC.NE.0) WRITE(6,20) I,XYZ,QT            00443500
          NVIGN=NVIGN+INDY                                              00443600
          GO TO 790                                                     00443700
C                DD END VIGNETTE CODING                                 00443800
C                D REFRACTION (MODIFICATION OF COSINES) EQUATIONS       00443900
C                FIND ZN, Z COMPONENT OF NON-UNIT NORMAL VECTOR TO      00444000
C                THE SURFACE AT POINT (X,Y,Z) - MEANINGLESS QUANTITY    00444100
C                FOR PLANAR SURFACE                                     00444200
C                GNU = RATIO OF OLD INDEX TO NEW INDEX                  00444300
  960     GNU    = TM2/TM1                                              00444400
          GO TO (980,970,980), ISW                                      00444500
  970     IF ( C(I).EQ.ZERO .AND. RDSPAC(I).EQ.ZERO ) GO TO 1060        00444600
          RNX = FTRA*X                                                  00444700
          RNY = FTRA*Y                                                  00444800
          RNZ = FTRA*((ONE + CONIC(I))*Z - R(I))                        00444900
C                NORMAL DOT NORMAL                                      00445000
          DOTNN = RNX*RNX + RNY*RNY + RNZ*RNZ                           00445100
C                NORMAL DOT COSINE VECTOR                               00445200
          DOTNQ = QX*RNX + QY*RNY + QZ*RNZ                              00445300
C                DIFFRACTION GRATING SURFACE                            00445400
  980     IF (RDSPAC(I)) 1090,990,1090                                  00445500
C                ASPHERIC SURFACE                                       00445600
  990     GO TO (1000,1020,1020), ISW                                   00445700
C                E ASPHERIC REFRACTION                                  00445800
C                ASPHERIC REFRACTION EQUATIONS                          00445900
C                             2      2                                  00446000
C                 /  ( 2     N      N   2)1/2                           00446100
C                F = (P (1- ---) + --- F )                              00446200
C                    (       2      2    )                              00446300
C                           N      N                                    00446400
C                            -1     -1                                  00446500
 1000     GN = (GNMONE*GNMONE-GSQ)*GNU*GNU+GSQ                          00446600
C                TEST FOR TOTAL INTERNAL REFLECTION (BREWSTERS ANGLE)   00446700
          IF (GN.LE.ZERO) GO TO 1010                                    00446800
          RTGN = FREF(I)*DSQRT(GN)                                      00446900
          GN=RTGN                                                       00447000
C                     1 ( /   N   )                                     00447100
C                G = ---(F - --- F)                                     00447200
C                     2 (    N    )                                     00447300
C                    P        -1                                        00447400
          DP = (GN-GNU*GNMONE)/GSQ                                      00447500
C                          N                                            00447600
C                NEW Q  = --- Q  + GU                                   00447700
C                     X   N    X                                        00447800
C                          -1                                           00447900
          QX = GNU*QX + U*DP                                            00448000
C                          N                                            00448100
C                NEW Q  = --- Q  + GV                                   00448200
C                     Y   N    Y                                        00448300
C                          -1                                           00448400
          QY = GNU*QY + V*DP                                            00448500
C                          N                                            00448600
C                NEW Q  = --- Q  +  GW                                  00448700
C                     Z   N    Z                                        00448800
C                          -1                                           00448900
          QZ = GNU*QZ + W*DP                                            00449000
C                HERE QX,QY,QZ ARE NEW DIRECTION COSINES OF RAY IN      00449100
C                DECENTERED, TILTED COORD AFTER REFRACTION THRU         00449200
C                ASPHERIC                                               00449300
          GO TO 1170                                                    00449400
C                EE END ASPHERIC REFRACTION                             00449500
C                E INTERNAL REFLECTION ACCOUNTING                       00449600
 1010     IF (OPTNB.NE.0) WRITE(6,60) I                                 00449700
          IF (NRAY.EQ.0.AND.IREF.GT.1) GO TO 1210                       00449800
          NREFL=NREFL+INDY                                              00449900
          GO TO 790                                                     00450000
C                EE END INT. REFL. ACTG.                                00450100
C                E QUADRIC (SPHERE, PLANE) TRANSFER EQ.S                00450200
 1020     IF ( DOTNN.EQ.ZERO .OR. DOTNQ.EQ.ZERO ) GO TO 1060            00450300
          TEMP=(DOTNN/(DOTNQ*DOTNQ))*(ONE-GNU*GNU)+GNU*GNU              00450400
          GMU=ZERO                                                      00450500
C                TEST FOR TOTAL INTERNAL REFLECTION                     00450600
          IF (TEMP) 1010,1030,1030                                      00450700
 1030     GMU = FREF(I)*DSQRT(TEMP)                                     00450800
          GMU = (GMU-GNU)*DOTNQ/DOTNN                                   00450900
          GO TO (1050,1050,1040), ISW                                   00451000
 1040     IF ( CX(I).EQ.ZERO ) GO TO 1045                               00451100
C             GENERAL TORIC REFRACTION EQUATIONS                        00451200
          QX = GNU*QX + GMU*TKS                                         00451300
          QY = GNU*QY + GMU*TLS                                         00451400
          QZ = GNU*QZ + GMU*TMS                                         00451500
          GO TO 1170                                                    00451600
C             CYLINDER REFRACTION EQUATIONS                             00451700
 1045     QX = GNU*QX + GMU*RNX                                         00451800
          QY = GNU*QY + GMU*RNY                                         00451900
          QZ = GNU*QZ + GMU*RNZ                                         00452000
          GO TO 1170                                                    00452100
C             CONIC,ACONIC REFRACTION EQUATIONS                         00452200
 1050     QX = GNU*QX + GMU*RNX                                         00452300
          QY = GNU*QY + GMU*RNY                                         00452400
          QZ = GNU*QZ + GMU*RNZ                                         00452500
          GO TO 1170                                                    00452600
C             PLANE REFRACTION EQUATIONS                                00452700
 1060     TEMP = ONE - GNU*GNU*(ONE-QZ*QZ)                              00452800
          GMU = ZERO                                                    00452900
          IF (TEMP) 1010,1080,1070                                      00453000
 1070     GMU = DSIGN(ONE,QZ) * FREF(I) * DSQRT(TEMP)                   00453100
 1080     GMU = GMU - GNU*QZ                                            00453200
          QX = GNU*QX                                                   00453300
          QY = GNU*QY                                                   00453400
          QZ = GNU*QZ + GMU                                             00453500
          GO TO 1170                                                    00453600
C                EE END QUADRIC REFRACTION                              00453700
C                E DIFFRACTION GRATING REFRACTION CODING                00453800
C                IS THIS A PLANE GRATING                                00453900
 1090     IF ( C(I) ) 1110,1100,1110                                    00454000
C                YES, SET NORMAL VECTOR AND PRODUCTS                    00454100
 1100     XND=ZERO                                                      00454200
          YND=ZERO                                                      00454300
          ZND=ONE                                                       00454400
          DOTNN=ONE                                                     00454500
          DOTNQ=QZ                                                      00454600
          GO TO 1120                                                    00454700
C                NOT PLANE                                              00454800
 1110     XND = RNX                                                     00454900
          YND = RNY                                                     00455000
          ZND = RNZ                                                     00455100
C                RULING DIRECTION - RDSPAC LT 0 IF X, GT 0 IF Y         00455200
 1120     IF (RDSPAC(I)) 1130,990,1140                                  00455300
C                X GRATING, FIND CAPITAL LAMDA                          00455400
 1130     SSQ=XND*XND+ZND*ZND                                           00455500
          V=-ONE/DSQRT(ONE+YND*YND/SSQ)                                 00455600
          U=-XND*V*YND/SSQ                                              00455700
          W=-ZND*V*YND/SSQ                                              00455800
C                USER SHALL SPECIFY THE SPACING OF DIFFRACTION GRATINGS 00455900
C                AS NOT FORESHORTENED FROM NORMAL TO THE GRATING        00456000
          RDLAM = ORDN(I,LAMDA)*WAVL(LAMDA)*DABS(V)/DABS(TM1*RDSPAC(I)) 00456100
          GO TO 1150                                                    00456200
C                Y GRATING, FIND CAPITAL LAMDA                          00456300
 1140     SSQ = YND*YND+ZND*ZND                                         00456400
          U   = ONE/DSQRT(ONE + XND*XND/SSQ)                            00456500
          V   = -YND*U*XND/SSQ                                          00456600
          W   = -ZND*U*XND/SSQ                                          00456700
          RDLAM = ORDN(I,LAMDA)*WAVL(LAMDA)*U/DABS(TM1*RDSPAC(I))       00456800
C                SOLVE QUADRATIC EQUATION FOR GAMMA                     00456900
 1150     B1 = (GNU*GNU - ONE + RDLAM*RDLAM - TWO*GNU*RDLAM*            00457000
     $       (U*QX + V*QY + W*QZ) )/DOTNN                               00457100
          A = GNU*DOTNQ/DOTNN                                           00457200
          ASQ = A*A                                                     00457300
          IF (B1-ASQ) 1160,1160,1010                                    00457400
 1160     RDGAM = FREF(I) * DSIGN(ONE,QZ) * DSQRT(ASQ-B1)               00457500
          RDGAM = -(A-RDGAM)                                            00457600
C                FIND NEW COSINES FOR RAY                               00457700
          QX = GNU*QX - RDLAM*U + RDGAM*XND                             00457800
          QY = GNU*QY - RDLAM*V + RDGAM*YND                             00457900
          QZ = GNU*QZ - RDLAM*W + RDGAM*ZND                             00458000
C                EE END OF DIFFRACTION GRATING CODING                   00458100
C                DD END OF REFRACTION EQUATIONS                         00458200
C                D RE-TRANSFORMATION TO OPTICAL AXIS COORDINATES AND    00458300
C                D DIRECTION                                            00458400
C                CONVERT BACK THRU OPPOSITE ROTATION                    00458500
C      FAKEB=0 NO DEROTATE NO DETRANSLATE                               00458600
C      FAKEB=1 TRANSLATES ONLY BACK TO ORIGINAL COORDINATES             00458700
C      FAKEB=2 DEROTATE ONLY BACK TO ORIGINAL COORDINATES               00458800
C      FAKEB=3 DEROTATES AND TRANSLATES BACK TO ORIGINAL COORDINATES    00458900
 1170     IF ( FAKEB(I).EQ.ZERO ) GO TO 1190                            00459000
          IF ( FAKEB(I).EQ.ONE  )  GO TO 1180                           00459100
          IF ( FAKEB(I).EQ.TWO .OR. FAKEB(I).EQ.THREE ) GO TO 1175      00459200
          GO TO 1190                                                    00459300
 1175     CALL VECMA (XYZ,XYZ)                                          00459400
          CALL VECMA (QT,QT)                                            00459500
          IF ( FAKEB(I).EQ.TWO )  GO TO 1190                            00459600
C                RE-CENTER COORD                                        00459700
 1180     X = X + XDISP(I)                                              00459800
          Y = Y + YDISP(I)                                              00459900
C                                                                       00460000
C                SIZEB = TRAVEL FROM SURFACE I-1 TO I                   00460100
C                      = OPTICAL PATH LENGTH                            00460200
 1190     SIZEB = (DN1 - DN + DN2)*TM2                                  00460300
C             PRINT INFO THIS SURF                                      00460400
          IF (OPTNC.NE.0.AND.IREF.LE.1) WRITE(6,20) I,XYZ,QT,SIZEB      00460500
C                SET PREVIOUS SURFACE PARAMS                            00460600
          PX = X                                                        00460700
          PY = Y                                                        00460800
          PZ = Z                                                        00460900
          PN = TM1                                                      00461000
          PT = T(I)                                                     00461100
C                END OF TRACE LOOP                                      00461200
 1200   CONTINUE                                                        00461300
C                DD END TRANSFORMATIONS                                 00461400
C                CC END SURFACE CALCULATIONS                            00461500
C                C IMAGE PLANE(S) ANALYSIS AND ACTG. FOR RAY            00461600
C                                                                       00461700
C                PERFORM REFERENCE SURFACE ITERATIONS                   00461800
C                                                                       00461900
C                VARIABLES:                                             00462000
C                                                                       00462100
C                   ORIGX,ORIGY: ORIGINAL X,Y COORDS                    00462200
C                                 AT ENTRANCEPUPIL                      00462300
C                   X2,Y2: NEW X,Y COORDS AT ENTPUP                     00462400
C                   DLTREF: DELTA X AND Y USED TO CALCULATE             00462500
C                           PARTIAL DERIVATIVES                         00462600
C                   TRACX1,TRACY1: REF SURF X,Y FOR ENTPUP X,Y          00462700
C                   TRACX2,TRACY2: REF SURF X,Y FOR ENTPUP X+DLTREF,Y   00462800
C                   TRACX3,TRACY3: REF SURF X,Y FOR ENTPUP X,Y+DLTREF   00462900
C                   DESX,DESY: DESIRED X,Y AT REFERENCE SURFACE         00463000
C                   ITREAD:  0 = NO REF SURF ITERATIONS PERFORMED       00463100
C                            1 = FINDING PARTIAL DERIVATIVES            00463200
C                            2 = FINDING NEW X,Y COORDS AT REF SURF     00463300
C                   IWHICH:  1 = FINDING NEW X,Y COORDS AT REF SURF     00463400
C                            2 = FINDING PARTIALS W.R.T. X              00463500
C                            3 = FINDING PARTIALS W.R.T. Y              00463600
C                   PX,PY: AFTER LABEL 1200 = X,Y COORDS AT REF SURF    00463700
C                                                                       00463800
C                FORMULAS:                                              00463900
C                                                                       00464000
C                   F1(X,Y) = PX                                        00464100
C                   F2(X,Y) = PY                                        00464200
C                   G1(X,Y) = PX-DESX                                   00464300
C                   G2(X,Y) = PY-DESY                                   00464400
C                                                                       00464500
C                           (G2(X,Y)*(DF1/DY))-(G1(X,Y)*(DF2/DY))       00464600
C                   CHX =  --------------------------------------       00464700
C                          ((DF1/DX)*(DF2/DY)-(DF2/DX)*(DF1/DY))        00464800
C                                                                       00464900
C                           (G2(X,Y)*(DF1/DX)-(G2(X,Y)*(DF2/DX))        00465000
C                   CHY =  ----------------------------------------     00465100
C                          ((DF1/DY)*(DF2/DX)-(DF2/DY)*(DF1/DX))        00465200
C                                                                       00465300
        IF (ITREAD.EQ.0) GO TO 1216                                     00465400
        NITRAT=NITRAT+1                                                 00465500
        IF (NITRAT.GT.48) GO TO 1209                                    00465600
        IF (ITREAD.EQ.2) GO TO 1204                                     00465700
        IF (IWHICH.EQ.1) GO TO 1201                                     00465800
        IF (IWHICH.EQ.2) GO TO 1202                                     00465900
        IF (IWHICH.EQ.3) GO TO 1203                                     00466000
C                                                                       00466100
 1201   X2=ORIGX                                                        00466200
        Y2=ORIGY                                                        00466300
        TRACX1=PX                                                       00466400
        TRACY1=PY                                                       00466500
        IF (DABS(PX-DESX).LE.EPSLON.AND.DABS(PY-DESY).LE.EPSLON)        00466600
     $     GO TO 1209                                                   00466700
        ONETHO=1.D+3                                                    00466800
        DLTREF=1.0/ONETHO                                               00466900
        IF (FMASK(1).GT.0) DLTREF=FMASK(1)/ONETHO                       00467000
        IF (ORIGX.GE.0) X2=ORIGX-DLTREF                                 00467100
        IF (ORIGX.LT.0) X2=ORIGX+DLTREF                                 00467200
        PX=X2                                                           00467300
        PY=Y2                                                           00467400
        PZ=ZHOLD                                                        00467500
        IWHICH=2                                                        00467600
        DX=X2-THISHX                                                    00467700
        DY=Y2-THISHY                                                    00467800
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00467900
        QX=DX/DENOM                                                     00468000
        QY=DY/DENOM                                                     00468100
        QZ=DZ/DENOM                                                     00468200
        GO TO 585                                                       00468300
C                                                                       00468400
 1202   TRACX2=PX                                                       00468500
        TRACY2=PY                                                       00468600
        X21=X2                                                          00468700
        IF (DABS(PX-DESX).LE.EPSLON.AND.DABS(PY-DESY).LE.EPSLON)        00468800
     $     GO TO 1209                                                   00468900
        IF (ORIGY.GE.0) Y2=ORIGY-DLTREF                                 00469000
        IF (ORIGY.LT.0) Y2=ORIGY+DLTREF                                 00469100
        X2=ORIGX                                                        00469200
        PX=X2                                                           00469300
        PY=Y2                                                           00469400
        PZ=ZHOLD                                                        00469500
        IWHICH=3                                                        00469600
        DX=X2-THISHX                                                    00469700
        DY=Y2-THISHY                                                    00469800
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00469900
        QX=DX/DENOM                                                     00470000
        QY=DY/DENOM                                                     00470100
        QZ=DZ/DENOM                                                     00470200
        GO TO 585                                                       00470300
C                                                                       00470400
 1203   TRACX3=PX                                                       00470500
        TRACY3=PY                                                       00470600
        Y21=Y2                                                          00470700
        IF (DABS(PX-DESX).LE.EPSLON.AND.DABS(PY-DESY).LE.EPSLON)        00470800
     $     GO TO 1209                                                   00470900
        IF (ORIGX.GE.0) X2=ORIGX-DLTREF                                 00471000
        IF (ORIGX.LT.0) X2=ORIGX+DLTREF                                 00471100
        IF (ORIGY.GE.0) Y2=ORIGY-DLTREF                                 00471200
        IF (ORIGY.LT.0) Y2=ORIGY+DLTREF                                 00471300
        CHX=X2-ORIGX                                                    00471400
        CHY=Y2-ORIGY                                                    00471500
        PX=X2                                                           00471600
        PY=Y2                                                           00471700
        PZ=ZHOLD                                                        00471800
        ITREAD=2                                                        00471900
        IWHICH=1                                                        00472000
        DX=X2-THISHX                                                    00472100
        DY=Y2-THISHY                                                    00472200
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00472300
        QX=DX/DENOM                                                     00472400
        QY=DY/DENOM                                                     00472500
        QZ=DZ/DENOM                                                     00472600
        QXHOLD=QX                                                       00472700
        QYHOLD=QY                                                       00472800
        QZHOLD=QZ                                                       00472900
        GO TO 585                                                       00473000
C                                                                       00473100
 1204   IF (IWHICH.EQ.1) GO TO 1206                                     00473200
        IF (IWHICH.EQ.3) GO TO 1208                                     00473300
C                                                                       00473400
 1206   IF (DABS(PX-DESX).LE.EPSLON.AND.DABS(PY-DESY).LE.EPSLON)        00473500
     $     GO TO 1209                                                   00473600
        FPR1X=(TRACX2-TRACX1)/CHX                                       00473700
        FPR2X=(TRACY2-TRACY1)/CHX                                       00473800
        FPR1Y=(TRACX3-TRACX1)/CHY                                       00473900
        FPR2Y=(TRACY3-TRACY1)/CHY                                       00474000
        G1XY=PX-DESX                                                    00474100
        G2XY=PY-DESY                                                    00474200
        UUJ=((FPR1X*FPR2Y)-(FPR2X*FPR1Y))                               00474300
        UUK=((FPR1Y*FPR2X)-(FPR2Y*FPR1X))                               00474400
        IF (UUJ.GT.0.AND.UUJ.LT.1.D-60) UUJ=1.D-60                      00474500
        IF (UUJ.LE.0.AND.UUJ.GT.-1.D-60) UUJ=-1.D-60                    00474600
        IF (UUK.GT.0.AND.UUK.LT.1.D-60) UUK=1.D-60                      00474700
        IF (UUK.LE.0.AND.UUK.GT.-1.D-60) UUK=-1.D-60                    00474800
        CHX=((G2XY*FPR1Y)-(G1XY*FPR2Y))/UUJ                             00474900
        CHY=((G2XY*FPR1X)-(G1XY*FPR2X))/UUK                             00475000
C                                                                       00475100
 1208   IF (DABS(PX-DESX).LE.EPSLON.AND.DABS(PY-DESY).LE.EPSLON)        00475200
     $     GO TO 1209                                                   00475300
        X2=ORIGX+CHX                                                    00475400
        Y2=ORIGY+CHY                                                    00475500
        PX=X2                                                           00475600
        PY=Y2                                                           00475700
        PZ=ZHOLD                                                        00475800
        IWHICH=1                                                        00475900
        ORIGX=X2                                                        00476000
        ORIGY=Y2                                                        00476100
        ITREAD=1                                                        00476200
        DX=X2-THISHX                                                    00476300
        DY=Y2-THISHY                                                    00476400
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00476500
        QX=DX/DENOM                                                     00476600
        QY=DY/DENOM                                                     00476700
        QZ=DZ/DENOM                                                     00476800
        QXHOLD=QX                                                       00476900
        QYHOLD=QY                                                       00477000
        QZHOLD=QZ                                                       00477100
        GO TO 585                                                       00477200
C                                                                       00477300
C               HERE IF ITERATED COORDINATES FOUND                      00477400
 1209   IF (NRAY.EQ.0.AND.NITRAT.GT.48) GO TO 1210                      00477500
        IF (NRAY.EQ.0) GO TO 1211                                       00477600
        DX=X2-THISHX                                                    00477700
        DY=Y2-THISHY                                                    00477800
        DENOM=DSQRT(DX*DX+DY*DY+DZ*DZ)                                  00477900
        QX=DX/DENOM                                                     00478000
        QY=DY/DENOM                                                     00478100
        QZ=DZ/DENOM                                                     00478200
        WRITE(50) X2,Y2,ZHOLD,QX,QY,QZ,THISHY,THISHX,DESX,DESY          00478300
        ITREAD=IONE                                                     00478400
        IWHICH=IONE                                                     00478500
        GO TO 570                                                       00478600
C                                                                       00478700
C               HERE IF CHIEF RAY CANNOT BE TRACED                      00478800
 1210   WRITE(6,213) THISY, THISX                                       00478900
        X2DEC=0                                                         00479000
        Y2DEC=0                                                         00479100
        IREF=-1                                                         00479200
        ITREAD=0                                                        00479300
        KFLAG=1                                                         00479400
        NSURF=NNSURF                                                    00479500
        GO TO 570                                                       00479600
C               CHIEF RAY CAN BE TRACED                                 00479700
C               PERFORM ITERATIONS NOW                                  00479800
 1211   NRAY=0                                                          00479900
        X2DEC=X2                                                        00480000
        Y2DEC=Y2                                                        00480100
        ITREAD=IONE                                                     00480200
        IWHICH=IONE                                                     00480300
        KFLAG=0                                                         00480400
        NSURF=NNSURF                                                    00480500
        GO TO 581                                                       00480600
C               WRITE RAY DATA TO UNIT 20                               00480700
 1216   IF (IPR20.EQ.IZERO) GO TO 1218                                  00480800
        WRITE(20,212) PX,PY,PZ,QX,QY,QZ,THISHY,THISHX                   00480900
C               FIND FINAL ANGLE TANGENTS                               00481000
 1218   IF (DABS(QZ).GT.ZERO) GO TO 1219                                00481100
        WRITE(6,210)                                                    00481200
        GO TO 1900                                                      00481300
 1219   TM1=QX/QZ                                                       00481400
        TM2=QY/QZ                                                       00481500
        PRINAN=PRINAN+TM2                                               00481600
        IF (UFLAG.LT.FOUR) GO TO 1220                                   00481700
        FPLANE=ZERO                                                     00481800
        NPLANE=1                                                        00481900
        FOCL=ONE                                                        00482000
        NFOC=0                                                          00482100
 1220   IF (OPTNB) 1230,1240,1230                                       00482200
C             PRINT TANGENTS, IMAGE PLANES BREAKDOWN HEADING            00482300
 1230   WRITE(6,90) TM1,TM2                                             00482400
        WRITE(6,80)                                                     00482500
C             TRANSFER TO IMAGE SURFACES VIA CLOSEST POINT METHOD       00482600
 1240   PT = T(NSURF) + FPLANE*DELIMP                                   00482700
        ZLOC = PT                                                       00482800
        RECX = ZERO                                                     00482900
        RECY = ZERO                                                     00483000
        IF ( FAKEB(NSURF).EQ.ONE .OR. FAKEB(NSURF).EQ.THREE )           00483100
     $       RECX = XDISP(NSURF)                                        00483200
        IF ( FAKEB(NSURF).EQ.ONE .OR. FAKEB(NSURF).EQ.THREE )           00483300
     $       RECY = YDISP(NSURF)                                        00483400
        IF ( FAKEA.GT.ZERO ) DN = ZERO                                  00483500
        I = IZERO                                                       00483600
 1250   I = I + IONE                                                    00483700
        IF ( I.GT.NPLANE ) GO TO 1345                                   00483800
        IF ( UFLAG.NE.FOUR ) GO TO 1260                                 00483900
        X = QX/QZ                                                       00484000
        Y = QY/QZ                                                       00484100
        GO TO 1300                                                      00484200
 1260   IF ( UFLAG.NE.FIVE ) GO TO 1270                                 00484300
        IF ( C(NSURF).EQ.ZERO ) X = DARCOS(QZOLD)                       00484400
        IF ( C(NSURF).NE.ZERO ) X = DARCOS(DOTNQ*DABS(C(NSURF)))        00484500
        Y = ZERO                                                        00484600
        GO TO 1300                                                      00484700
 1270   DN = (PT-PZ)*QZ - PY*QY - PX*QX                                 00484800
        DN1 = DN                                                        00484900
        XT = X + DN*QX - RECX                                           00485000
        YT = Y + DN*QY - RECY                                           00485100
        ZT = Z + DN*QZ - PT                                             00485200
C                END OF CLOSEST-POINT TRANSFER                          00485300
C                TRANSFER RAY TO IMAGE SURFACE                          00485400
C                CONIC, SPHERIC, PLANE TRANSFER EQUATIONS               00485500
        IF ( CVIMG.EQ.ZERO .AND. QZ.EQ.ZERO ) GO TO 780                 00485600
        DN2 = -ZT/QZ                                                    00485700
        IF ( CVIMG.EQ.ZERO ) GO TO 1290                                 00485800
        FTRA = -DSIGN( ONE,QZ*RADIMG )                                  00485900
        HALPHA = ONE + CONIMG*QZ*QZ                                     00486000
        HBETA  = XT*QX + YT*QY + (ONE+CONIMG)*ZT*QZ - RADIMG*QZ         00486100
        HGAMMA = XT*XT + YT*YT + (ONE+CONIMG)*ZT*ZT - TWO*RADIMG*ZT     00486200
        TEMP1  = HBETA*HBETA - HALPHA*HGAMMA                            00486300
C                TEST FOR MISS IF NEG RADICAL                           00486400
        IF ( DABS(TEMP1).LT.EPS1 ) TEMP1 = ZERO                         00486500
        IF ( TEMP1.LT.ZERO ) GO TO 780                                  00486600
        TEMP = FTRA * DSQRT(TEMP1)                                      00486700
        IF ( DABS(HGAMMA).LT.EPS1 ) GO TO 1280                          00486800
        DENOM = HBETA + TEMP                                            00486900
        IF ( DABS(DENOM).LT.EPS1 ) GO TO 1285                           00487000
        DN2 = -HGAMMA/DENOM                                             00487100
        GO TO 1290                                                      00487200
 1280   DN2 = (HBETA-TEMP)/HALPHA                                       00487300
        GO TO 1290                                                      00487400
 1285   DN2 = ZERO                                                      00487500
 1290   X = XT + DN2*QX                                                 00487600
        Y = YT + DN2*QY                                                 00487700
        Z = ZT + DN2*QZ                                                 00487800
 1300   XSUM(I) = XSUM(I) + X*INDX                                      00487900
        YSUM(I) = YSUM(I) + Y*INDY                                      00488000
        XSUMSQ(I) = XSUMSQ(I) + X*X*INDY                                00488100
        YSUMSQ(I) = YSUMSQ(I) + Y*Y*INDY                                00488200
        XUS = X + RECX                                                  00488300
        YUS = Y + RECY                                                  00488400
C             NO PRINT UNLESS PRIME IMAGE PLANE                         00488500
        IF ( I.NE.NIMG ) GO TO 1340                                     00488600
C                WRITE X,Y ON SPOTPLOT TAPE                             00488700
C                IF FIRST RAY THROUGH, INITIALIZE PLOT MAX, MIN         00488800
        IF (NTHRU.NE.0) GO TO 1310                                      00488900
        IF (IALLPL.EQ.1) GO TO 1310                                     00489000
        XMINS = XUS                                                     00489100
        XMAXS = XUS                                                     00489200
        YMINS = YUS                                                     00489300
        YMAXS = YUS                                                     00489400
 1310   FAKEX = XUS                                                     00489500
C                ACCUMULATE MAX AND MIN X AND Y OVER IMAGE POINTS       00489600
        IF ( YUS.GT.YMAXS ) YMAXS = YUS                                 00489700
        IF ( YUS.LT.YMINS ) YMINS = YUS                                 00489800
 1320   IF ( FAKEX.GT.XMAXS ) XMAXS = FAKEX                             00489900
        IF ( FAKEX.LT.XMINS ) XMINS = FAKEX                             00490000
        FAKEX = -FAKEX                                                  00490100
C                IF MODE = 0 CONSIDER + AND -X                          00490200
        IF ( FAKEX.EQ.-XUS .AND. XUS.NE.ZERO .AND. IMODE.EQ.0 )         00490300
     $     GO TO 1320                                                   00490400
        IF ( IPLTPR.NE.0 .OR. OPTNE.NE.0 .OR. OPTNF.NE.0 )              00490500
     $     WRITE(34) XUS,YUS                                            00490600
        IF ( IPLTPR.NE.0 .AND. IALLPL.EQ.1) GO TO 1325                  00490700
        GO TO 1327                                                      00490800
 1325   IJK=IJK+1                                                       00490900
        IF (IJK.LE.7600) GO TO 1326                                     00491000
        WRITE(6,218)                                                    00491100
        IALLPL=0                                                        00491200
        GO TO 1327                                                      00491300
 1326   XKALL(IJK)=XUS                                                  00491400
        YKALL(IJK)=YUS                                                  00491500
 1327   IF ( OPTNA.EQ.0 ) GO TO 1330                                    00491600
C             PRINT X,Y,Z                                               00491700
        WRITE(6,40) XUS,YUS,Z                                           00491800
C             IF MODE = 0 WRITE, PRINT -X,Y,Z                           00491900
 1330   IF ( IMODE.NE.0 ) GO TO 1340                                    00492000
        FAKEX = -XUS                                                    00492100
        IF ( IPLTPR.NE.0 .OR. OPTNE.NE.0 .OR. OPTNF.NE.0 )              00492200
     $     WRITE(34) FAKEX,YUS                                          00492300
        IF ( IPLTPR.NE.0 .AND. IALLPL.EQ.1) GO TO 1335                  00492400
        GO TO 1337                                                      00492500
 1335   IJK=IJK+1                                                       00492600
        IF (IJK.LE.7600) GO TO 1336                                     00492700
        WRITE(6,218)                                                    00492800
        IALLPL=0                                                        00492900
        GO TO 1337                                                      00493000
 1336   XKALL(IJK)=FAKEX                                                00493100
        YKALL(IJK)=YUS                                                  00493200
 1337   IF ( OPTNA.EQ.0 ) GO TO 1340                                    00493300
        WRITE(6,40) FAKEX,YUS,Z                                         00493400
 1340   IF ( OPTNB.NE.0 ) WRITE(6,100) ZLOC,XUS,YUS,Z                   00493500
        PT = DELIMP                                                     00493600
        ZLOC = ZLOC + DELIMP                                            00493700
        GO TO 1250                                                      00493800
C                UPDATE NUMBER OF RAYS THRU                             00493900
 1345   NTHRU=NTHRU+INDY                                                00494000
        GO TO 570                                                       00494100
C                CC END IMAGE ANAL. FOR RAY                             00494200
C                BB END RAY PROC FOR THIS COLOR                         00494300
C                B IMAGE ANALYSIS FOR ALL RAYS, THIS HEIGHT, THIS COLOR 00494400
C             PRINT FINAL IMAGE PLANE ANALYSIS HERE                     00494500
C                FLOAT NUMBER RAYS THRU                                 00494600
 1350   TIMES=NTHRU                                                     00494700
        IF (NTHRU+NMISS+NREFL+NVIGN.EQ.0) GO TO 1360                    00494800
C             PRINT ACCOUNT                                             00494900
        IF (LATYPE.EQ.6) WRITE(6,105) LAMDA,NTHRU,NREFL,NMISS,NVIGN     00495000
        IF (LATYPE.EQ.6) GO TO 1360                                     00495100
        WRITE(6,110) LAMDA,HYLAST,HXLAST,NTHRU,NREFL,NMISS,NVIGN        00495200
C                CLOSE PLOT                                             00495300
C                NEW HEIGHT TO HOLDER                                   00495400
 1360   HYSAVE=HYLAST                                                   00495500
        HXSAVE=HXLAST                                                   00495600
        HYLAST=THISHY                                                   00495700
        HXLAST=THISHX                                                   00495800
        IF (IREF.GT.IONE.OR.KFLAG.EQ.1) GO TO 1870                      00495900
C                SKIP IF NO RAYS THRU                                   00496000
        IF (NTHRU.LT.1) GO TO 1870                                      00496100
        WRITE(6,120)                                                    00496200
C                POSITION OF PLANE                                      00496300
        Z=T(NSURF)+FPLANE*DELIMP                                        00496400
        DO 1390 I=1,NPLANE                                              00496500
C                FIND AVERAGES                                          00496600
          XAVG=XSUM(I)/TIMES                                            00496700
          YAVG=YSUM(I)/TIMES                                            00496800
          RMSX=ZERO                                                     00496900
          RMSY=ZERO                                                     00497000
          SPOT=ZERO                                                     00497100
C                IF ONE RAY ONLY RMS =0                                 00497200
          IF (TIMES.EQ.ONE) GO TO 1370                                  00497300
C                CALCULATE ROOT MEAN SQUARES                            00497400
C                NOTE STD DEV OF X AND Y ARE MISNAMED RMSX, RMSY        00497500
          RMSX=XSUMSQ(I)/TIMES-XAVG*XAVG                                00497600
          IF ( DABS(RMSX).LT.EPS1 ) RMSX = DABS(RMSX)                   00497700
          RMSX=DSQRT(RMSX)                                              00497800
C                                                                       00497900
          RMSY=YSUMSQ(I)/TIMES-YAVG*YAVG                                00498000
          IF ( DABS(RMSY).LT.EPS1 ) RMSY = DABS(RMSY)                   00498100
          RMSY=DSQRT(RMSY)                                              00498200
C                SPOT SIZE = MEASURE OF IMAGE SIZE                      00498300
          SPOT=DSQRT(RMSX*RMSX+RMSY*RMSY)                               00498400
          IF (IFOC.LT.0) BLOB(I)=RMSX                                   00498500
          IF (IFOC.EQ.0) BLOB(I)=SPOT                                   00498600
          IF (IFOC.GT.0) BLOB(I)=RMSY                                   00498700
          ZF(I)=Z                                                       00498800
          XAVG=XAVG+RECX                                                00498900
          YAVG=YAVG+RECY                                                00499000
 1370     WRITE(6,100) Z,XAVG,YAVG,RMSX,RMSY,SPOT                       00499100
C                RESTORE ACCUMULATORS                                   00499200
C                SAVE X, Y AVERAGES, SPOT RADIUS IF PRIME IMAGE PLANE   00499300
          IF (I.NE.NIMG) GO TO 1380                                     00499400
          AVGX=XAVG                                                     00499500
          AVGY=YAVG                                                     00499600
          SPOTP=SPOT                                                    00499700
          IF (IALLPL.EQ.0) GO TO 1380                                   00499800
          IHITE=IHITE+1                                                 00499900
          AHITE=IHITE                                                   00500000
          AVXALL=(((IHITE-1)*AVXALL)+AVGX)/AHITE                        00500100
          AVYALL=(((IHITE-1)*AVYALL)+AVGY)/AHITE                        00500200
          XALLSQ=XALLSQ+XSUMSQ(I)                                       00500300
          YALLSQ=YALLSQ+YSUMSQ(I)                                       00500400
 1380     XSUM(I)=ZERO                                                  00500500
          YSUM(I)=ZERO                                                  00500600
          XSUMSQ(I)=ZERO                                                00500700
          YSUMSQ(I)=ZERO                                                00500800
          Z=Z+DELIMP                                                    00500900
 1390   CONTINUE                                                        00501000
        IF (NFOC.EQ.0) GO TO 1400                                       00501100
        NUMP=NPLANE                                                     00501200
        CALL FOCUS (ZF,BLOB,NUMP,FID)                                   00501300
        NFOC=0                                                          00501400
        LFOC=0                                                          00501500
        T(NSURF)=FID                                                    00501600
        REWIND 34                                                       00501700
        GO TO 300                                                       00501800
C                                                                       00501900
C             REWIND 34 BEFORE RED OR MTF CALCULATION                   00502000
C                                                                       00502100
 1400   REWIND 34                                                       00502200
C                                                                       00502300
C   COMPUTE RED IF NEEDED; AVOID RED CALC. IF POSSIBLE                  00502400
C                                                                       00502500
C   RED  NEEDED IF    IPLTPR IS ON,                                     00502600
C         OR          IOPB    "  ",                                     00502700
C         OR          IOPC    "  ",                                     00502800
C         OR          OPTNE   "  ",                                     00502900
C         OR          OPTNF   "  ".                                     00503000
C                                                                       00503100
        IF( IPLTPR .NE. 0) GO TO 1540                                   00503200
        IF( IOPB   .NE. 0) GO TO 1540                                   00503300
        IF( IOPC   .NE. 0) GO TO 1540                                   00503400
        IF( OPTNE  .NE. 0) GO TO 1540                                   00503500
        IF( OPTNF  .NE. 0) GO TO 1540                                   00503600
C                                                                       00503700
C   SKIP RED CALCULATION (NOT NEEDED)                                   00503800
        GO TO 1870                                                      00503900
C                                                                       00504000
C            RED CALCULATION                                            00504100
C            GET DEVIATIONS OF RAYS FROM CENTROID.                      00504200
C       RP(I) - RMS DEVIATION OF ITH RAY                                00504300
C                                                                       00504400
 1540   DO 1560 I=1,NTHRU                                               00504500
        READ (34) XK(I),YK(I)                                           00504600
        RP(I)=DSQRT((XK(I)-AVGX)*(XK(I)-AVGX)+(YK(I)-AVGY)*             00504700
     $     (YK(I)-AVGY))                                                00504800
 1560   CONTINUE                                                        00504900
C                                                                       00505000
C     STORE RADII IN ASCENDING ORDER (SEE USER'S GUIDE P. 4-39)         00505100
C                                                                       00505200
        DO 1620 I=1,NTHRU                                               00505300
          TEMP=RP(I)                                                    00505400
          TEMPR=TEMP                                                    00505500
          ITEMP=I                                                       00505600
          DO 1610 J=I,NTHRU                                             00505700
            IF (TEMP.LT.RP(J)) GO TO 1610                               00505800
            TEMP=RP(J)                                                  00505900
            ITEMP=J                                                     00506000
 1610     CONTINUE                                                      00506100
          RP(I)=TEMP                                                    00506200
          RP(ITEMP)=TEMPR                                               00506300
 1620   CONTINUE                                                        00506400
        IF (IOPA.NE.0.AND.IALLPL.EQ.0) CALL FNDSPT                      00506500
C                                                                       00506600
        CALL RED                                                        00506700
C                                                                       00506800
C                IF NO MTF NEEDED, WE ARE THROUGH                       00506900
C                                                                       00507000
 1750   IF ( IOPC.EQ.0 .AND. OPTNF.EQ.0 ) GO TO 1860                    00507100
C                                                                       00507200
        CALL MTF                                                        00507300
C                                                                       00507400
 1860   REWIND 34                                                       00507500
C                                                                       00507600
C                RESET VARIABLES, RETURN TO NEXT PASS                   00507700
C                                                                       00507800
 1870   NRAY=0                                                          00507900
        NTHRU=0                                                         00508000
        NREFL=0                                                         00508100
        NMISS=0                                                         00508200
        NVIGN=0                                                         00508300
        KFLAG=0                                                         00508400
        ORIGX=ORIGX-X2DEC                                               00508500
        ORIGY=ORIGY-Y2DEC                                               00508600
        IF (IIREF.GT.1.AND.IREF.EQ.1) IREF=IIREF                        00508700
        IF (OPTNA.NE.0.AND.IEOF.NE.1) WRITE(6,30)                       00508800
        GO TO (1875,580), IEOF                                          00508900
 1875 IF (IOPA.EQ.0.OR.IALLPL.EQ.0) GO TO 1880                          00509000
C               HERE IF MULTIPLE SPOT PLOT DESIRED                      00509100
      AVGX=AVXALL                                                       00509200
      AVGY=AVYALL                                                       00509300
      TIMES=IJK                                                         00509400
C                CALCULATE ROOT MEAN SQUARES                            00509500
C                NOTE STD DEV OF X AND Y ARE MISNAMED RMSX, RMSY        00509600
      RMSX=XALLSQ/TIMES-AVGX*AVGX                                       00509700
      IF ( DABS(RMSX).LT.EPS1 ) RMSX = DABS(RMSX)                       00509800
      RMSX=DSQRT(RMSX)                                                  00509900
C                                                                       00510000
      RMSY=YALLSQ/TIMES-AVGY*AVGY                                       00510100
      IF ( DABS(RMSY).LT.EPS1 ) RMSY = DABS(RMSY)                       00510200
      RMSY=DSQRT(RMSY)                                                  00510300
C                SPOT SIZE = MEASURE OF IMAGE SIZE                      00510400
      SPOTP=DSQRT(RMSX*RMSX+RMSY*RMSY)                                  00510500
      CALL GRAPH(2,4)                                                   00510600
 1880 CONTINUE                                                          00510700
      IF (IREF.LE.0) GO TO 1890                                         00510800
C               CLOSE UNIT 50                                           00510900
      IREF=IZERO                                                        00511000
      GARB=-2                                                           00511100
      WRITE(50) (GARB, I=1,10)                                          00511200
      END FILE 50                                                       00511300
      REWIND 50                                                         00511400
      LAMDA=ICOL(1)                                                     00511500
      NRAY=0                                                            00511600
      NTHRU=0                                                           00511700
      NREFL=0                                                           00511800
      NMISS=0                                                           00511900
      NVIGN=0                                                           00512000
      NSURF=NNSURF                                                      00512100
      GO TO 550                                                         00512200
 1890 CONTINUE                                                          00512300
C                BB END MACRO IMAGE ANALYSIS                            00512400
C                AA END PROCESSING THIS COLOR                           00512500
C                RESET IREF TO REFERENCE SURFACE NUMBER                 00512600
 1900 IREF=IIREF                                                        00512700
      IF (FAKEA.EQ.ZERO) GO TO 1910                                     00512800
      FAKEA=ZERO                                                        00512900
      T(NSURF)=THCK                                                     00513000
      NSURF=NNSURF                                                      00513100
      DELIMP=DLMP                                                       00513200
      FPLANE=FPLN                                                       00513300
      NPLANE=NPLN                                                       00513400
      IPR20=0                                                           00513500
C                                                                       00513600
      GARB=-2                                                           00513700
      WRITE(20,212) (GARB, I=1,8)                                       00513800
      REWIND 20                                                         00513900
 1910 RETURN                                                            00514000
      END                                                               00514100
C                                                                       00514200
C*******************************************************                00514300
      SUBROUTINE SRFSAG                                                 00514400
C*******************************************************                00514500
C                                                                       00514600
C            THIS ROUTINE ADDED 9-11-80; IT COMPUTES A TABLE            00514700
C            OF SAGS OF SURFACE "ISURF",FOR HEIGHTS BETWEEN             00514800
C            "YMIN" AND "YMAX" (INCLUSIVE) WITH A STEP OF "DELY".       00514900
C            A CONSTANT "CONST" CAN BE ADDED AS WELL.  THE USER CAN     00515000
C            CHOOSE TO HAVE THE DIFFERENCES IN SAG BETWEEN THE          00515100
C            SURFACE AND A SURFACE OF CURVATURE "REFCRV" (E.G. A SPHERE)00515200
C            COMPUTED AS WELL, OR HAVE THE SAGS COMPUTED IN TERMS       00515300
C            OF WAVELENGTHS OF LIGHT USING "WAVENM" AS THE REFERENCE    00515400
C            WAVELENGTH; "WAVENM" IS THE WAVELENGTH IN NANOMETERS       00515500
C            THE SURFACE MUST BE ROTATIONALLY SYMMETRIC                 00515600
C                                                                       00515700
      IMPLICIT REAL *8 (A-H,O-Z)                                        00515800
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00515900
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00516000
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00516100
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00516200
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00516300
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00516400
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00516500
     $                FREF(40),FREF0,WAVL(3)                            00516600
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00516700
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00516800
     $                IPR20,IREF,IJK,IALLPL                             00516900
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00517000
C                                                                       00517100
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,IZERO/0/          00517200
C                 TEST TO SEE IF ISRF IS A VALID SURFACE NUMBER         00517300
C                                                                       00517400
      IF ( ISRF.GT.NSURF .OR. ISRF.LE.IZERO ) GO TO 180                 00517500
      I = ISRF                                                          00517600
C                 ISRF IS A VALID SURFACE NUMBER IF HERE                00517700
C                 WRITE HEADER LABELS                                   00517800
C                 CONVERT WAVELENGTH TO SYSTEM UNITS FOR CALCULATIONS   00517900
      UNITS = UFLAG                                                     00518000
      IF ( UNITS.EQ.ZERO .OR. UNITS.EQ.ONE ) WAVE = WAVENM*1.E-6        00518100
      IF ( UNITS.EQ.TWO ) WAVE = WAVENM*1.E-7                           00518200
      IF ( UNITS.EQ.THREE ) WAVE = WAVENM*1.E-7/2.54                    00518300
      IF ( REFCRV.EQ.ZERO .AND.WAVENM.EQ.ZERO) WRITE(6,10) I            00518400
      IF ( REFCRV.EQ.ZERO .AND.WAVENM.NE.ZERO) WRITE(6,20) I            00518500
      IF ( REFCRV.NE.ZERO .AND.WAVENM.EQ.ZERO) WRITE(6,30) I            00518600
      IF ( REFCRV.NE.ZERO .AND.WAVENM.NE.ZERO) WRITE(6,40) I            00518700
 10   FORMAT(//T2,'SURF ',I3,T14,'Y',T28,'SAG'/)                        00518800
 20   FORMAT(//T2,'SURF ',I3,T14,'Y',T28,'SAG',                         00518900
     $      T46,'SAG DIFFERENCE IN WAVELENGTHS'/)                       00519000
 30   FORMAT(//T2,'SURF ',I3,T14,'Y',T28,'SAG',                         00519100
     $      T46,'SAG - REFERENCE SAG'/)                                 00519200
 40   FORMAT(//T2,'SURF ',I3,T14,'Y',T28,'SAG',                         00519300
     $      T46,'SAG-REFERENCE SAG',T70,                                00519400
     $      T70,'SAG DIFFERENCE IN WAVELENGTHS'/)                       00519500
C                 STARTING WITH Y = YMIN, COMPUTE SAGS                  00519600
C                                                                       00519700
      IF ( DABS(DELY).LT.1.D-8 ) DELY = ( YMAX-YMIN )/25.               00519800
      Y = YMIN                                                          00519900
 50   CONTINUE                                                          00520000
      YSQ = Y*Y                                                         00520100
C                 COMPUTE CONIC CONTRIBUTION TO SAG                     00520200
C                 CONIC CONSTANT = -(ECCENTRICITY)**2                   00520300
      TEMP = C(I)*YSQ                                                   00520400
      DENOM = 1.+DSQRT(1.-(1.+CONIC(I))*C(I)*TEMP)                      00520500
      SAG = TEMP/DENOM                                                  00520600
C                 COMPUTE ACONIC CONTRIBUTION TO SAG, IF ANY            00520700
C                 THIS INCLUDES 4TH THRU 10TH POWER TERMS               00520800
      A4  = COEF(I,1)                                                   00520900
      A6  = COEF(I,2)                                                   00521000
      A8  = COEF(I,3)                                                   00521100
      A10 = COEF(I,4)                                                   00521200
C                                                                       00521300
      ACONIC = DABS(A4) + DABS(A6) + DABS(A8) + DABS(A10)               00521400
      IF( ACONIC.EQ.ZERO ) GO TO 60                                     00521500
      TEMP = YSQ*(A2+YSQ*(A4+YSQ*(A6+YSQ*(A8+A10*YSQ))))                00521600
      SAG = SAG + TEMP                                                  00521700
C                                                                       00521800
 60   CONTINUE                                                          00521900
C                 ADD CONSTANT TO SAG                                   00522000
      SAG = SAG + CONST                                                 00522100
C                 SET "DIFF" = SAG IF SAG IN WAVELENGTHS DESIRED        00522200
      DIFF = SAG                                                        00522300
C                                                                       00522400
C                 COMPUTE REFERENCE SAG IF DESIRED                      00522500
      IF ( REFCRV.EQ.ZERO ) GO TO 70                                    00522600
      TEMP = REFCRV * YSQ                                               00522700
      DENOM = 1. + DSQRT(1.-REFCRV*TEMP)                                00522800
      REFSAG = TEMP/DENOM                                               00522900
      DIFF = SAG - REFSAG                                               00523000
 70   CONTINUE                                                          00523100
C                 COMPUTE DIFFERENCE IN SAG OF THE SURFACE AND REFERENCE00523200
C                 SURFACE IN WAVELENGTHS OF LIGHT IF DESIRED            00523300
      IF ( WAVENM.EQ.ZERO ) GO TO 80                                    00523400
      DIFFWV = DIFF/WAVE                                                00523500
 80   CONTINUE                                                          00523600
C                 WRITE Y,SAG, DIFF, AND WAVES OF SAG                   00523700
      IF ( REFCRV.EQ.ZERO .AND.WAVENM.EQ.ZERO ) WRITE(6,90) Y,SAG       00523800
      IF ( REFCRV.EQ.ZERO .AND.WAVENM.NE.ZERO ) WRITE(6,100)Y,SAG,DIFFWV00523900
      IF ( REFCRV.NE.ZERO .AND.WAVENM.EQ.ZERO ) WRITE(6,110) Y,SAG,DIFF 00524000
      IF( REFCRV.NE.ZERO.AND.WAVENM.NE.ZERO )                           00524100
     $   WRITE(6,120) Y,SAG,DIFF,DIFFWV                                 00524200
 90   FORMAT(1X,T9,F8.3,T22,1PE15.7)                                    00524300
 100  FORMAT(1X,T9,F8.3,T22,1PE15.7,T46,1PE15.7)                        00524400
 110  FORMAT(1X,T9,F8.3,T22,1PE15.7,T46,1PE15.7)                        00524500
 120  FORMAT(1X,T9,F8.3,T22,1PE15.7,T46,1PE15.7,T72,1PE15.7)            00524600
C                                                                       00524700
      Y = Y+DELY                                                        00524800
      IF ( Y.GT.YMAX ) GO TO 140                                        00524900
      GO TO 50                                                          00525000
 140  WRITE(6,150) CONST                                                00525100
 150  FORMAT(/6X,'CONSTANT ADDED TO EACH SAG',T34,'=',T36,1PE15.7)      00525200
      WRITE(6,160) REFCRV                                               00525300
 160  FORMAT(6X,'REFERENCE CURVATURE',T34,'=',T36,1PE15.7)              00525400
      WRITE(6,170) WAVENM                                               00525500
 170  FORMAT(6X,'REFERENCE WAVELENGTH',T34,'=',T36,1PE15.7,' NM'//)     00525600
      GO TO 200                                                         00525700
 180  WRITE(6,190) ISRF                                                 00525800
 190  FORMAT(1X,/5X,'INVALID SURFACE NUMBER GIVEN FOR SAG OPTION',      00525900
     $       ', SURFACE NUMBER = ',I3//)                                00526000
C                                                                       00526100
C             RESET PARAMETERS, RETURN                                  00526200
C                                                                       00526300
  200 ISRF   = IZERO                                                    00526400
      YMAX   = ZERO                                                     00526500
      YMIN   = ZERO                                                     00526600
      DELY   = ZERO                                                     00526700
      REFCRV = ZERO                                                     00526800
      CONST  = ZERO                                                     00526900
      WAVENM = ZERO                                                     00527000
      RETURN                                                            00527100
      END                                                               00527200
C                                                                       00527300
C******************************************************                 00527400
      SUBROUTINE SURFNO (ICHAR,LEN2,ISURF,JSURF)                        00527500
C******************************************************                 00527600
C                                                                       00527700
      IMPLICIT REAL*8 (A-H,O-Z)                                         00527800
C                                                                       00527900
      DIMENSION ICHAR(LEN2),NUMBER(10)                                  00528000
C                                                                       00528100
C     THE PURPOSE OF THIS ROUTINE IS TO DETERMINE A SURFACE NUMBER      00528200
C     FOR STORING DATA READ IN THE MAIN PROGRAM                         00528300
C                                                                       00528400
C     ICHAR  = WORD 2 OF INPUT CARD (SEE MAIN PROGRAM)                  00528500
C     ISURF = CURRENT SURFACE NUMBER, EQUALS MAXIMUM                    00528600
C     JSURF  = SURFACE NUMBER FROM CARD OR CURRENT SURFACE NUMBER       00528700
C                                                                       00528800
      DATA NUMBER /'1','2','3','4','5','6','7','8','9','0'/             00528900
      DATA IBLANK /' '/,IZERO/0/,ITEN/10/,IONE/1/,IFORTY/40/,ICOMM/','/ 00529000
C                                                                       00529100
      IF ( ICHAR(1).NE.IBLANK.AND.ICHAR(1).NE.ICOMM ) GO TO 20          00529200
C             SURFACE NUMBER FROM CARD IS BLANK, USE CURRENT SURFACE NO.00529300
   10 JSURF = ISURF                                                     00529400
      GO TO 100                                                         00529500
C             FOUND CHARACTERS ON CARD, DETERMINE SURFACE NUMBER        00529600
   20 INDEX1 = IZERO                                                    00529700
      INDEX2 = IZERO                                                    00529800
      IVAL1  = IZERO                                                    00529900
      IVAL2  = IZERO                                                    00530000
      DO 40 I=1,LEN2                                                    00530100
        DO 30 J=1,10                                                    00530200
          IF ( ICHAR(I).EQ.NUMBER(J) ) GO TO 50                         00530300
   30   CONTINUE                                                        00530400
   40 CONTINUE                                                          00530500
C             NO NUMBER, USE CURRENT SURFACE NUMBER                     00530600
      GO TO 10                                                          00530700
C                                                                       00530800
C             FOUND FIRST NUMBER, DECODE AND LOOK FOR SECOND NUMBER     00530900
   50 INDEX1 = ITEN                                                     00531000
      IVAL1  = J                                                        00531100
      IF ( IVAL1.EQ.ITEN ) IVAL1 = IZERO                                00531200
      IF ( ICHAR(I+1).EQ.IBLANK ) GO TO 70                              00531300
C             TRY TO MATCH SECOND NUMBER                                00531400
      DO 60 J=1,10                                                      00531500
        IF ( ICHAR(I+1).EQ.NUMBER(J) ) GO TO 80                         00531600
   60 CONTINUE                                                          00531700
C             ONLY ONE DIGIT                                            00531800
   70 INDEX1 = IONE                                                     00531900
      INDEX2 = IZERO                                                    00532000
      IVAL2  = IZERO                                                    00532100
      GO TO 90                                                          00532200
C                                                                       00532300
C             FOUND MATCH, DECODE                                       00532400
   80 INDEX2 = IONE                                                     00532500
      IVAL2 = J                                                         00532600
      IF ( IVAL2.EQ.ITEN ) IVAL2 = IZERO                                00532700
C                                                                       00532800
C             DETERMINE SURFACE NUMBER                                  00532900
   90 JSURF = INDEX1*IVAL1 + INDEX2*IVAL2                               00533000
C                                                                       00533100
  100 IF ( JSURF.LT.IZERO .OR. JSURF.GT.IFORTY ) JSURF = ISURF          00533200
      RETURN                                                            00533300
      END                                                               00533400
C                                                                       00533500
C*******************************************************                00533600
      SUBROUTINE SURTYP(I)                                              00533700
C*******************************************************                00533800
C       THIS ROUTINE IS CALLED FROM PARAX AND ADDS THE CAPABILITY       00533900
C       OF HANDLING SURFACES ENTIRELY DESCRIBED BY A POLYNOMIAL         00534000
C       EXPRESSION AND CONIC SURFACES WHICH HAVE DEFORMATION CONSTANTS  00534100
C                                                                       00534200
      IMPLICIT REAL *8 (A-H,O-Z)                                        00534300
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00534400
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00534500
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00534600
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00534700
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00534800
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00534900
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00535000
     $                FREF(40),FREF0,WAVL(3)                            00535100
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00535200
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00535300
     $                IPR20,IREF,IJK,IALLPL                             00535400
      COMMON /ABCODE/ ISURFX,ISURXN,RSAVE,TM3,DUM(40),RR(40),RCON(40)   00535500
C                                                                       00535600
      DIMENSION TOR(40)                                                 00535700
C                                                                       00535800
      EQUIVALENCE (Y0(1),TOR(1))                                        00535900
C                                                                       00536000
      DATA ZERO/0.D0/                                                   00536100
C                                                                       00536200
      DUM(I) = ZERO                                                     00536300
      RR(I) = R(I)                                                      00536400
      RCON(I) =  CONIC(I)                                               00536500
      IF ( R(I).NE.ZERO ) GO TO 10                                      00536600
C        SURFTYPE MAY BE A PLANE                                        00536700
      IF ( COEF(I,1).NE.ZERO ) GO TO 40                                 00536800
C        SURFACE IS A PLANE NO ABERRATION                               00536900
      GO TO 50                                                          00537000
  10  IF ( RCON(I).NE.ZERO ) GO TO 20                                   00537100
C        SURFACE IS A SPHERE                                            00537200
      GO TO 30                                                          00537300
C        SURFACE IS A CONIC                                             00537400
  20  DUM(I) = RCON(I)*TM3*TM3*TM3/8.                                   00537500
  30  IF ( COEF(I,1) .EQ. ZERO ) GO TO 50                               00537600
  40  DUM(I) = DUM(I)+COEF(I,1)                                         00537700
  50  IF ( TOR(I).EQ.ZERO ) GO TO 60                                    00537800
      ENTRY SURTOR(I)                                                   00537900
      ISURXN = I                                                        00538000
      ISURFX = 1                                                        00538100
      IF ( R(I).NE.ZERO .AND. RX(I).NE.ZERO ) ISURFX = 2                00538200
      IF ( R(I).NE.ZERO .AND. RX(I).EQ.ZERO ) ISURFX = 3                00538300
      IF ( R(I).EQ.ZERO .AND. RX(I).NE.ZERO ) ISURFX = 4                00538400
      RSAVE = RX(I)                                                     00538500
      IF ( ISURFX.EQ.3 ) RSAVE = R(I)                                   00538600
  60  RETURN                                                            00538700
      END                                                               00538800
C                                                                       00538900
C*******************************************************                00539000
      SUBROUTINE RED                                                    00539100
C*******************************************************                00539200
C                ROUTINE RED PERFORMS RADIAL ENERGY DISTRIBUTION        00539300
C                CALCULATIONS                                           00539400
      IMPLICIT REAL *8 (A-H,O-Z)                                        00539500
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00539600
C                                                                       00539700
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00539800
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00539900
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00540000
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00540100
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00540200
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00540300
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00540400
     $                FREF(40),FREF0,WAVL(3)                            00540500
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00540600
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00540700
     $                IPR20,IREF,IJK,IALLPL                             00540800
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00540900
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00541000
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00541100
      COMMON /CRED/ RPP(40),EPP(40),XW(812),HYSAVE,HXSAVE,              00541200
     $             TIMES,RD,OPTNE,ISW,IOPB                              00541300
      COMMON /CMTF/   AJ, AN, AR(40), DE(40), DELTCC, DELTEN, DELTPL,   00541400
     $                EN, IOPC, OPTNF, PRINAN, RSC, SUM, TX(51)         00541500
      COMMON /CSPOT/  XTMAX,XTMIN,YTMAX,YTMIN,AVGX,AVGY,RP(812),SPOTP,  00541600
     $                XK(812),YK(812),XKALL(7600),YKALL(7600),JSKIP,    00541700
     $                IOPA,NTHRU                                        00541800
C                                                                       00541900
C                                                                       00542000
      DIMENSION YW(812),TOR(40)                                         00542100
      DIMENSION ZF(10),BLOB(10)                                         00542200
      DIMENSION XSUM(10),YSUM(10),XSUMSQ(10),YSUMSQ(10)                 00542300
      DIMENSION QT(3),XX(3),XYZ(3)                                      00542400
C                                                                       00542500
      EQUIVALENCE (QT(1),QX),(QT(2),QY),(QT(3),QZ)                      00542600
      EQUIVALENCE (XX(1),XT),(XX(2),YT),(XX(3),ZT)                      00542700
      EQUIVALENCE (XYZ(1),X),(XYZ(2),Y),(XYZ(3),Z)                      00542800
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00542900
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00543000
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00543100
      EQUIVALENCE (TRASH(10),FBNU),(Y0(1),TOR(1))                       00543200
C                                                                       00543300
C                                                                       00543400
      DATA IZERO/0/,IONE/1/                                             00543500
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/        00543600
      DATA FIVE/5.D0/,SIX/6.D0/,TEN/10.D0/,HUNDRD/100.D0/,THOUS/1000.D0/00543700
      DATA EPS1/1.D-9/,EPS2/1.D-14/,PI/3.141592653589793D0/             00543800
 140  FORMAT (11H0Y OBJ.PNT.,5X,1PE15.8,2X,10HX OBJ.PNT.,5X,1PE15.8)    00543900
 150  FORMAT (9H0COLOR   ,5X,I6)                                        00544000
 160  FORMAT (1X,'  PERCENT ENERGY',7X,'RADIUS')                        00544100
 170  FORMAT (1X,I8,8X,1PE15.8)                                         00544200
C                CALCULATE PERCENT ENERGY AND ADJUSTED RADIUS ARRAYS    00544300
 1710   DO 1720 I=1,40                                                  00544400
          IPL=I*.025*TIMES                                              00544500
          EPP(I)=.025*I                                                 00544600
          RPP(I)=RP(IPL)                                                00544700
 1720   CONTINUE                                                        00544800
        IF (ISW.EQ.0) RSMAX=0.                                          00544900
C            PRINT RED TABLE?                                           00545000
 1730   IF (OPTNE.EQ.0) GO TO 1750                                      00545100
        WRITE(6,140) HYSAVE,HXSAVE                                      00545200
        WRITE(6,150) LAMDA                                              00545300
        WRITE(6,160)                                                    00545400
        DO 1740 I=2,40,2                                                00545500
          II=I*2.5                                                      00545600
          WRITE(6,170) II,RPP(I)                                        00545700
 1740   CONTINUE                                                        00545800
C            PLOT RED?                                                  00545900
       IF (IOPB.EQ.0) GO TO 1750                                        00546000
       CALL GRAPH(2,2)                                                  00546100
 1750  RETURN                                                           00546200
       END                                                              00546300
C                                                                       00546400
C*******************************************************                00546500
      SUBROUTINE MTF                                                    00546600
C                                                                       00546700
C        PURPOSE                                                        00546800
C               PERFORM MODULATION TRANSFER CALCULATIONS                00546900
C                                                                       00547000
C        PARAMETERS -NONE                                               00547100
C                                                                       00547200
C        REFERENCE - GENOPTICS USER GUIDE CHAP. 4                       00547300
C                                                                       00547400
C        ACTIVE VARIABLES                                               00547500
C                                                                       00547600
C           INPUT:                                                      00547700
C   /PMATX/    FOCL           SYSTEM FOCAL LENGTH                       00547800
C                               DEFAULT IF(FOCL = 0.0) FOCL = 100.0     00547900
C                                                                       00548000
C   /CMTF/     IOPC           MTF PLOT SWITCH                           00548100
C   /COLLAT/   IWVFLG(I)      WAVELENGTH SET FLAG                       00548200
C   /HEAD/     LAMDA          RAY COLOR INDEX                           00548300
C   /CMTF/     OPTNF          MTF PRINT OPTION SWITCH(INTEGER*4)        00548400
C   /CMTF/     PRINAN         SUM OF (QY/QZ) FOR EACH RAY               00548500
C   /CSPOT/    RP(I)          SEE USER'S GUIDE                          00548600
C   /PMATX/    SMAX           MAX OBJECT DISTANCE (?)                   00548700
C                               SEE LINE LABLED 1765 BELOW              00548800
C                             *** NOTE  AS ISW IS USED HERE, IF         00548900
C                             SMAX = 0.0 ON ENTRY, THEN SMAX = 0.0      00549000
C                             ON EXIT.  THE DEFAULT IS USED ONLY        00549100
C                             INTERNALLY TO  MTF.                       00549200
C                                                                       00549300
C   /CRED/     TIMES          NUMBER OF RAYS(?)                         00549400
C   /PMATX/    WAVL(LAMDA)    USER SPECIFIED WAVELENGTH/DEFAULTS        00549500
C           OUTPUT:                                                     00549600
C  /CMTF/          AN         ANGLE OF PRINCIPLE RAY(?)                 00549700
C  /CMTF/          DE(I)      ?                                         00549800
C                  DEFWV(3)   DEFAULT WAVELENGTHS (NANOMETERS)          00549900
C                               DEFWV(1) = 632.8                        00550000
C                               DEFWV(2) = 587.6                        00550100
C                               DEFWV(3) = 486.1                        00550200
C                                                                       00550300
C  /CMTF/          DELTCC     ?                                         00550400
C  /CMTF/          DELTEN     ?                                         00550500
C  /CMTF/          DELTPL     ?                                         00550600
C  /CMTF/          EN                                                   00550700
C  /CMTF/          EPP                                                  00550800
C                  IPL                                                  00550900
C  /CRED/          ISW                                                  00551000
C  /CRED/          RPP                                                  00551100
C  /CMTF/          RSC                                                  00551200
C  /CMTF/          SUM                                                  00551300
C  /CMTF/          TX                                                   00551400
C  /PMATX/         WAVL                                                 00551500
C                  X                                                    00551600
C                                                                       00551700
C  LAST UPTDATE 4/20/84 BY JOHN C PARKER OF SSAI                        00551800
C                                                                       00551900
C*******************************************************                00552000
C     SUBROUTINE MTF                                                    00552100
C                ROUTINE MTF PERFORMS MODULATION TRANSFER               00552200
C                FUNCTION CALCULATIONS                                  00552300
      IMPLICIT REAL *8 (A-H,O-Z)                                        00552400
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00552500
C                                                                       00552600
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00552700
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00552800
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00552900
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00553000
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00553100
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00553200
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00553300
     $                FREF(40),FREF0,WAVL(3)                            00553400
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00553500
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00553600
     $                IPR20,IREF,IJK,IALLPL                             00553700
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00553800
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00553900
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00554000
      COMMON /CRED/   RPP(40),EPP(40),XW(812),HYSAVE,HXSAVE,            00554100
     $                TIMES,RD,OPTNE,ISW,IOPB                           00554200
      COMMON /CMTF/   AJ, AN, AR(40), DE(40), DELTCC, DELTEN, DELTPL,   00554300
     $                EN, IOPC, OPTNF, PRINAN, RSC, SUM, TX(51)         00554400
      COMMON /CSPOT/  XTMAX,XTMIN,YTMAX,YTMIN,AVGX,AVGY,RP(812),SPOTP,  00554500
     $                XK(812),YK(812),XKALL(7600),YKALL(7600),JSKIP,    00554600
     $                IOPA,NTHRU                                        00554700
C                                                                       00554800
C                                                                       00554900
C                                                                       00555000
      DIMENSION YW(812),TOR(40),DEFWV(3)                                00555100
      DIMENSION ZF(10),BLOB(10)                                         00555200
      DIMENSION XSUM(10),YSUM(10),XSUMSQ(10),YSUMSQ(10)                 00555300
      DIMENSION QT(3),XX(3),XYZ(3)                                      00555400
C                                                                       00555500
      EQUIVALENCE (QT(1),QX),(QT(2),QY),(QT(3),QZ)                      00555600
      EQUIVALENCE (XX(1),XT),(XX(2),YT),(XX(3),ZT)                      00555700
      EQUIVALENCE (XYZ(1),X),(XYZ(2),Y),(XYZ(3),Z)                      00555800
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00555900
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00556000
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00556100
      EQUIVALENCE (TRASH(10),FBNU),(Y0(1),TOR(1))                       00556200
C                                                                       00556300
C                                                                       00556400
      DATA IZERO/0/,IONE/1/                                             00556500
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/        00556600
      DATA FIVE/5.D0/,SIX/6.D0/,TEN/10.D0/,HUNDRD/100.D0/,THOUS/1000.D0/00556700
      DATA EPS1/1.D-9/,EPS2/1.D-14/,PI/3.141592653589793D0/             00556800
C                                                                       00556900
  190 FORMAT (///9X,5HFREQ.,11X,3HMTF/,6X,11H(CYCLES/MR)/)              00557000
  200 FORMAT (1X,1PE15.8,2X,1PE15.8)                                    00557100
  208 FORMAT(//10X,'NO WAVELENGTH INPUT FOR MTF; ',F5.1,                00557200
     $       ' NM BEING USED'/)                                         00557300
  209 FORMAT(10X,'NO FOCAL LENGTH INPUT FOR MTF; F.L. SET = 100'/)      00557400
C                                                                       00557500
C                                                                       00557600
 1710   DO 1720 I=1,40                                                  00557700
          IPL=I * IDINT(.025*TIMES)                                     00557800
          EPP(I)=.025 * DFLOAT(I)                                       00557900
          RPP(I)=RP(IPL)                                                00558000
 1720   CONTINUE                                                        00558100
        DEFWV(1)=632.8                                                  00558200
        DEFWV(2)=587.6                                                  00558300
        DEFWV(3)=486.1                                                  00558400
        ISW=0                                                           00558500
        IF (SMAX.NE.ZERO) GO TO 1770                                    00558600
C                IF NO MAX CYCLES/MR SPECIFIED, CALCULATE               00558700
        ISW=1                                                           00558800
        IF (IWVFLG(LAMDA).EQ.ZERO) GO TO 1760                           00558900
        WRITE(6,208) DEFWV(LAMDA)                                       00559000
        IF (UFLAG.EQ.ONE) WAVL(LAMDA) = DEFWV(LAMDA) * 1.D-6            00559100
        IF (UFLAG.EQ.TWO) WAVL(LAMDA) = DEFWV(LAMDA) * 1.D-7            00559200
        IF (UFLAG.EQ.THREE) WAVL(LAMDA) = DEFWV(LAMDA) * 1.D-7/2.54D0   00559300
 1760   IF ( FOCL.NE.ZERO ) GO TO 1765                                  00559400
        WRITE(6,209)                                                    00559500
        FOCL = HUNDRD                                                   00559600
C             COMPUTE MAX SPATIAL FREQUENCY, CYCLES/RAD                 00559700
 1765   SMAX=ONE/(WAVL(LAMDA)*TWO*RHO/DABS(FOCL))                       00559800
C             CONVERT TO CYCLES/MR                                      00559900
        SMAX=SMAX/THOUS                                                 00560000
        JSMAX = IDINT(SMAX)                                             00560100
        SMAX = DFLOAT(JSMAX)                                            00560200
C                AN IS ANGLE OF PRINCIPAL RAY                           00560300
 1770 CONTINUE                                                          00560400
        AN=DATAN(PRINAN/TIMES)                                          00560500
C                SET UP MTF CALCULATION PARAMETERS                      00560600
        RSC=ONE/DCOS(AN)                                                00560700
        DELTEN=SMAX/50.                                                 00560800
        DELTPL=DELTEN*FIVE                                              00560900
        DELTCC=ONE/DELTPL                                               00561000
        IF ( OPTNF.EQ.0 ) GO TO 1800                                    00561100
C             HEAD MTF PRINT                                            00561200
 1780   WRITE(6,190)                                                    00561300
C                CALCULATE MTF                                          00561400
C                MODULATION TRANSFER FUNCTION (MTF) CAN BE CALCULATED   00561500
C                FROM RADIAL ENERGY DISTRIBUTION DATA BY THE FOLLOWING  00561600
C                FORMULA FOR EACH FREQUENCY                             00561700
C                MTF = SUM FROM 1 TO M (HERE 40) OF                     00561800
C                     DELTA E SUB I * J SUB ZERO OF                     00561900
C                     (2.*PI*NU*R BAR SUB I)                            00562000
C                WHERE                                                  00562100
C                DELTA E SUB I IS THE CHANGE IN ENERGY E(I+1)-E(I)      00562200
C                OVER EACH INTERVAL                                     00562300
C                J SUB ZERO IS THE ZERO ORDER BESSEL FUNCTION           00562400
C                R BAR SUB I IS THE AVERAGE RADIUS OVER THE             00562500
C                INTERVAL (R(I+1)+R(I))/2.                              00562600
C                NU IS THE FREQUENCY FOR WHICH THE FUNCTION IS          00562700
C                CALCULATED.NU=EN*1000/!FOCL!                           00562800
C                NU IS IN CYCLES PER UNIT LENGTH                        00562900
 1800   DO 1810 I=1,39                                                  00563000
          AR(I)=(RPP(I+1)+RPP(I))/2                                     00563100
          DE(I)=EPP(I+1)-EPP(I)                                         00563200
 1810   CONTINUE                                                        00563300
        DO 1850 K=1,51                                                  00563400
          EN=(K-1)*DELTEN                                               00563500
          SUM=ZERO                                                      00563600
          DO 1830 I=1,39                                                00563700
C                                                                       00563800
C NEXT LINE CORRECTED 4/11/84 BY JCP                                    00563900
C                                                                       00564000
            X=TWO*PI*EN*AR(I)*THOUS/(DABS(FOCL) * RSC)                  00564100
            CALL BESJN (X,0,AJ,ONE,IER)                                 00564200
            IF ( IER.EQ.0 ) GO TO 1825                                  00564300
            WRITE(6,1820) X,IER                                         00564400
 1820       FORMAT (25X,'X =',3X,1PE15.8,5X,'IER =',I5)                 00564500
            AJ=ONE                                                      00564600
 1825       SUM=SUM+DE(I)*AJ                                            00564700
 1830     CONTINUE                                                      00564800
          TX(K)=SUM/EPP(39)                                             00564900
          IF (OPTNF.EQ.0) GO TO 1850                                    00565000
C             PRINT MTF VALUES                                          00565100
 1840     WRITE(6,200) EN,TX(K)                                         00565200
 1850   CONTINUE                                                        00565300
        IF (IOPC.EQ.0) GO TO 1860                                       00565400
        CALL GRAPH(2,3)                                                 00565500
 1860   IF (ISW.EQ.1) SMAX=ZERO                                         00565600
 1900 RETURN                                                            00565700
      END                                                               00565800
C                                                                       00565900
C********************************************************               00566000
      SUBROUTINE GRAPH(IGRSW,IKIND)                                     00566100
C********************************************************               00566200
C                ROUTINE GRAPH PLOTS SPOT,RED, AND MTF DATA             00566300
C                                                                       00566400
      IMPLICIT REAL *8 (A-H,O-Z)                                        00566500
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00566600
C                                                                       00566700
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00566800
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00566900
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00567000
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00567100
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00567200
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00567300
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00567400
     $                FREF(40),FREF0,WAVL(3)                            00567500
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00567600
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00567700
     $                IPR20,IREF,IJK,IALLPL                             00567800
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00567900
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00568000
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00568100
      COMMON /CRED/   RPP(40),EPP(40),XW(812),HYSAVE,HXSAVE,            00568200
     $                TIMES,RD,OPTNE,ISW,IOPB                           00568300
      COMMON /CMTF/   AJ, AN, AR(40), DE(40), DELTCC, DELTEN, DELTPL,   00568400
     $                EN, IOPC, OPTNF, PRINAN, RSC, SUM, TX(51)         00568500
      COMMON /CSPOT/  XTMAX,XTMIN,YTMAX,YTMIN,AVGX,AVGY,RP(812),SPOTP,  00568600
     $                XK(812),YK(812),XKALL(7600),YKALL(7600),JSKIP,    00568700
     $                IOPA,NTHRU                                        00568800
C                                                                       00568900
C                                                                       00569000
      DIMENSION YW(812),TOR(40)                                         00569100
      DIMENSION ZF(10),BLOB(10)                                         00569200
      DIMENSION XSUM(10),YSUM(10),XSUMSQ(10),YSUMSQ(10)                 00569300
      DIMENSION QT(3),XX(3),XYZ(3)                                      00569400
      DIMENSION MSGA(4),MSGB(4),MSGC(6),MSGD(6),MSGE(3),MSGF(2),MSGG(4) 00569500
      DIMENSION MSGH(3),MSGI(3),MSGJ(4),MSGK(6),MSGL(4),MSGM(11),MSGN(2)00569600
      DIMENSION MSGO(5),MSGP(5),MSGQ(7),MSGR(1),MSGS(6),MSGT(6),MSGU(6) 00569700
      DIMENSION MSGV(4),MSGW(4),MSGX(4),MSGY(5),MSGZ(5)                 00569800
      DIMENSION MSG1(4),MSG2(1),MSG3(5),MSG4(3)                         00569900
C                                                                       00570000
      EQUIVALENCE (QT(1),QX),(QT(2),QY),(QT(3),QZ)                      00570100
      EQUIVALENCE (XX(1),XT),(XX(2),YT),(XX(3),ZT)                      00570200
      EQUIVALENCE (XYZ(1),X),(XYZ(2),Y),(XYZ(3),Z)                      00570300
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00570400
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00570500
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00570600
      EQUIVALENCE (TRASH(10),FBNU),(Y0(1),TOR(1))                       00570700
C                                                                       00570800
      DATA MSGA/4HX-AX,4HIS I,4HN IN,4HCHES/                            00570900
      DATA MSGB/4HY-AX,4HIS I,4HN IN,4HCHES/                            00571000
      DATA MSGC/4HX-AX,4HIS I,4HN CE,4HNTIM,4HETER,4HS   /              00571100
      DATA MSGD/4HY-AX,4HIS I,4HN CE,4HNTIM,4HETER,4HS   /              00571200
      DATA MSGE/4HSCAL,4HE FA,4HCTOR/                                   00571300
      DATA MSGF/4HCOLO,4HR   /                                          00571400
      DATA MSGG/4HNUMB,4HER O,4HF PO,4HINTS/                            00571500
      DATA MSGH/4HX-AV,4HERAG,4HE = /                                   00571600
      DATA MSGI/4HY-AV,4HERAG,4HE = /                                   00571700
      DATA MSGJ/4HRADI,4HUS I,4HN IN,4HCHES/                            00571800
      DATA MSGK/4HRADI,4HUS I,4HN CE,4HNTIM,4HETER,4HS   /              00571900
      DATA MSGL/4HPERC,4HENT ,4HENER,4HGY  /                            00572000
      DATA MSGM/4HSPAT,4HIAL ,4HFREQ,4HUENC,4HY, C,4HYCLE,4HS PE,4HR MI,00572100
     $          4HLLIR,4HADIA,4HN   /                                   00572200
      DATA MSGN/4HCONT,4HRAST/                                          00572300
      DATA MSGO/4HGEOM,4HETRI,4HCAL ,4HMTF ,4H    /                     00572400
      DATA MSGP/4HGEOM,4HETRI,4HCAL ,4HRED ,4H    /                     00572500
      DATA MSGQ/4HOBJE,4HCT H,4HEIGH,4HT (R,4HADIA,4HNS) ,4H X= /       00572600
      DATA MSGR/4H Y= /                                                 00572700
      DATA MSGS/4HX-AX,4HIS I,4HN MI,4HLLIM,4HETER,4HS   /              00572800
      DATA MSGT/4HY-AX,4HIS I,4HN MI,4HLLIM,4HETER,4HS   /              00572900
      DATA MSGU/4HRADI,4HUS I,4HN MI,4HLLIM,4HETER,4HS   /              00573000
      DATA MSGV/4HX-AX,4HIS I,4HN UN,4HITS /                            00573100
      DATA MSGW/4HY-AX,4HIS I,4HN UN,4HITS /                            00573200
      DATA MSGX/4HRADI,4HUS I,4HN UN,4HITS /                            00573300
      DATA MSGY/4HX-AX,4HIS I,4HN RA,4HDIAN,4HS   /                     00573400
      DATA MSGZ/4HY-AX,4HIS I,4HN RA,4HDIAN,4HS   /                     00573500
      DATA MSG1/4HTAN(,4HANGL,4HE)  ,4H    /                            00573600
      DATA MSG2/4H    /                                                 00573700
      DATA MSG3/4HANGL,4HE OF,4H INC,4HIDEN,4HCE  /                     00573800
      DATA MSG4/4HSPOT,4H RAD,4HIUS=/                                   00573900
C                                                                       00574000
      DATA IZERO/0/,IONE/1/, IFOUR/4/                                   00574100
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/        00574200
      DATA FIVE/5.D0/,SIX/6.D0/,TEN/10.D0/,HUNDRD/100.D0/,THOUS/1000.D0/00574300
      DATA EPS1/1.D-9/,EPS2/1.D-14/,PI/3.141592653589793D0/             00574400
 207  FORMAT(10X,'POINT SKIPPED ON SPOT PLOT')                          00574500
C                                                                       00574600
      IF (IGRSW.EQ.1) GO TO 2000                                        00574700
      IF (IGRSW.EQ.2) GO TO 10                                          00574800
      IF (IGRSW.EQ.3) GO TO 3000                                        00574900
      WRITE(6,1)                                                        00575000
  1   FORMAT(T5,' ERROR IN IGRSW ')                                     00575100
      GO TO 4000                                                        00575200
  10  COL = LAMDA                                                       00575300
      HTNX=DATAN2(HXSAVE,S-D)                                           00575400
      HTNY=DATAN2(HYSAVE,S-D)                                           00575500
      CALL PLOT(.5,0.,3)                                                00575600
      DIV=TEN                                                           00575700
      DELTPL=DELTEN*FIVE                                                00575800
      IF (IKIND.EQ.1) GO TO 1400                                        00575900
      IF (IKIND.EQ.2) GO TO 1600                                        00576000
      IF (IKIND.EQ.3) GO TO 1800                                        00576100
      IF (IKIND.EQ.4) GO TO 1400                                        00576200
      WRITE(6,20)                                                       00576300
  20  FORMAT(T5,' ERROR IN IKIND')                                      00576400
      GO TO 4000                                                        00576500
C            HERE IF SPOT PLOT                                          00576600
 1400   IF (IOPA.EQ.0) GO TO 1420                                       00576700
        ISW=0                                                           00576800
C                XD, YD = AXIS INCREMENTS                               00576900
        XD=(XSMAX-XSMIN)/SIX                                            00577000
        YD=(YSMAX-YSMIN)/SIX                                            00577100
C                IF NO MAX, MIN SPECIFIED FOR AXES, SCALE AXES          00577200
        IF (XD*YD.EQ.ZERO) GO TO 1410                                   00577300
C                XW(4)= ADJUSTED X INCREMENT                            00577400
C                ISW IS ZERO RESTORE SWITCH                             00577500
        ISW=1                                                           00577600
        GO TO 1420                                                      00577700
C                SET UP SCALE SUBR PARAMETERS                           00577800
 1410   XW(1)=XMINS                                                     00577900
        XW(2)=XMAXS                                                     00578000
        XW(5)=YMINS                                                     00578100
        XW(6)=YMAXS                                                     00578200
        IF (XMINS.EQ.XW(2)) XW(2)=XMINS*TWO                             00578300
        IF (YMINS.EQ.XW(6)) XW(6)=YMINS*TWO                             00578400
        CALL SCALE(XW(1),6.,2,2)                                        00578500
        CALL SCALE(XW(5),6.,2,2)                                        00578600
C                ON RETURN, XW(3)= ADJUSTED X MIN                       00578700
C                XW(7)= ADJUSTED Y MIN                                  00578800
C                XW(8)= ADJUSTED Y INC                                  00578900
        XSMIN=XW(3)                                                     00579000
        XSMAX=XW(4)*SIX+XSMIN                                           00579100
        YSMIN=XW(7)                                                     00579200
        YSMAX=XW(8)*SIX+YSMIN                                           00579300
        XD=XW(4)                                                        00579400
        YD=XW(8)                                                        00579500
 1420   CONTINUE                                                        00579600
        XT=.5                                                           00579700
        YT=ZERO                                                         00579800
        DO 1430 I=1,42                                                  00579900
          YT=YT+.25                                                     00580000
          XT=.75-XT                                                     00580100
 1430   CALL PLOT (XT,YT,2)                                             00580200
        XT=.75-XT                                                       00580300
        CALL PLOT (XT,YT,2)                                             00580400
        DO 1440 I=1,42                                                  00580500
          XT=.75-XT                                                     00580600
          YT=YT-.25                                                     00580700
 1440   CALL PLOT (XT,YT,2)                                             00580800
        SF = ONE/XD                                                     00580900
        IF (IALLPL.EQ.1) GO TO 1445                                     00581000
        CALL SYMBOL (1.2,10.0,.14,MSGQ,0.,28)                           00581100
        CALL NUMBER (5.1,10.0,.14,HTNX,0.,6)                            00581200
        CALL SYMBOL (6.3,10.0,.14,MSGR,0.,3)                            00581300
        CALL NUMBER (6.8,10.0,.14,HTNY,0.,6)                            00581400
 1445   CALL SYMBOL (1.2,9.7,.14,MSGF,0.,6)                             00581500
        CALL NUMBER (2.0,9.7,.14,COL,0.,-1)                             00581600
        CALL SYMBOL (2.3,9.7,.14,MSGG,0.,16)                            00581700
        CALL NUMBER (4.6,9.7,.14,TIMES,0.,-1)                           00581800
        CALL SYMBOL (5.2,9.7,.14,MSGE,0.,12)                            00581900
        CALL NUMBER (7.0,9.7,.14,SF,0.,4)                               00582000
        CALL SYMBOL (1.2,9.4,.14,MSGH,0.,11)                            00582100
        CALL NUMBER (2.8,9.4,.14,AVGX,0.,6)                             00582200
        CALL SYMBOL (4.3,9.4,.14,MSGI,0.,11)                            00582300
        CALL NUMBER (5.9,9.4,.14,AVGY,0.,6)                             00582400
        CALL SYMBOL (1.2,9.1,.14,MSG4,0.,12)                            00582500
        CALL NUMBER (3.0,9.1,.14,SPOTP,0.,6)                            00582600
        CALL PLOT (1.2,2.5,-3)                                          00582700
C             UFLAG=ONE IF UNITS ARE MILLIMETERS                        00582800
C             UFLAG=TWO IF UNITS ARE CENTIMETERS                        00582900
C             UFLAG=THREE IF UNITS ARE INCHES                           00583000
C             UFLAG=FOUR IF UNITS ARE RADIANS                           00583100
C             UFLAG=FIVE, IF PLOTTING ANGLES OF INCIDENCE               00583200
        IF (UFLAG.EQ.ONE)   GO TO 1460                                  00583300
        IF (UFLAG.EQ.TWO)   GO TO 1465                                  00583400
        IF (UFLAG.EQ.THREE) GO TO 1470                                  00583500
        IF (UFLAG.EQ.FOUR)  GO TO 1475                                  00583600
        IF (UFLAG.EQ.FIVE)  GO TO 1480                                  00583700
        GO TO 1485                                                      00583800
 1460   CALL AXIS (0.,0.,MSGT,21,6.,90.,YSMIN,YD)                       00583900
        GO TO 1490                                                      00584000
 1465   CALL AXIS (0.,0.,MSGD,21,6.,90.,YSMIN,YD)                       00584100
        GO TO 1490                                                      00584200
 1470   CALL AXIS (0.,0.,MSGB,16,6.,90.,YSMIN,YD)                       00584300
        GO TO 1490                                                      00584400
 1475   CALL AXIS (0.,0.,MSGZ,17,6.,90.,YSMIN,YD)                       00584500
        GO TO 1490                                                      00584600
 1480   CALL AXIS (0.,0.,MSG3,-18,6.,0.,XSMIN,XD)                       00584700
        GO TO 1530                                                      00584800
 1485   CALL AXIS (0.,0.,MSGW,15,6.,90.,YSMIN,YD)                       00584900
 1490   CALL AXIS (0.,6.,MSG2,1,6.,0.,XSMIN,XD)                         00585000
        CALL AXIS (6.,0.,MSG2,-1,6.,90.,YSMIN,YD)                       00585100
        IF (UFLAG.EQ.ONE)   GO TO 1495                                  00585200
        IF (UFLAG.EQ.TWO)   GO TO 1500                                  00585300
        IF (UFLAG.EQ.THREE) GO TO 1505                                  00585400
        IF (UFLAG.EQ.FOUR)  GO TO 1510                                  00585500
        IF (UFLAG.EQ.FIVE)  GO TO 1530                                  00585600
        GO TO 1515                                                      00585700
 1495   CALL AXIS (0.,0.,MSGS,-21,6.,0.,XSMIN,XD)                       00585800
        GO TO 1520                                                      00585900
 1500   CALL AXIS (0.,0.,MSGC,-21,6.,0.,XSMIN,XD)                       00586000
        GO TO 1520                                                      00586100
 1505   CALL AXIS (0.,0.,MSGA,-16,6.,0.,XSMIN,XD)                       00586200
        GO TO 1520                                                      00586300
 1510   CALL AXIS (0.,0.,MSGY,-17,6.,0.,XSMIN,XD)                       00586400
        GO TO 1520                                                      00586500
 1515   CALL AXIS (0.,0.,MSGV,-15,6.,0.,XSMIN,XD)                       00586600
 1520   XP = .5                                                         00586700
        DO 1525 IND=1,25                                                00586800
          INDD = IND+80                                                 00586900
          CALL SYMBOL (XP,-1.,.2,NAME(INDD),0.,1)                       00587000
          XP = XP+.2                                                    00587100
 1525   CONTINUE                                                        00587200
 1530   JSKIP=0                                                         00587300
 1540   NPTS=NTHRU                                                      00587400
        IF (IALLPL.EQ.1) NPTS=IJK                                       00587500
        DO 1560 I=1,NPTS                                                00587600
C                XT, YT ARE PLOT COORD                                  00587700
          IF (IALLPL.EQ.1) GO TO 1544                                   00587800
          XT=(XK(I)-XSMIN)/XD                                           00587900
          YT=(YK(I)-YSMIN)/YD                                           00588000
          GO TO 1546                                                    00588100
 1544     XT=(XKALL(I)-XSMIN)/XD                                        00588200
          YT=(YKALL(I)-YSMIN)/YD                                        00588300
 1546     IF (I.NE.1) GO TO 1550                                        00588400
C                INITIALIZE MAX, MIN COORD                              00588500
          XTMAX=XT                                                      00588600
          YTMAX=YT                                                      00588700
          XTMIN=XT                                                      00588800
          YTMIN=YT                                                      00588900
C                ACCUM MAX, MIN COORD CALCULATED                        00589000
 1550     IF (XT.GT.XTMAX) XTMAX=XT                                     00589100
          IF (YT.GT.YTMAX) YTMAX=YT                                     00589200
          IF (YT.LT.YTMIN) YTMIN=YT                                     00589300
          IF (XT.LT.XTMIN) XTMIN=XT                                     00589400
C                IF POINT OUT OF GRID, SKIP PLOTTING IT                 00589500
          IF (XT.LT.ZERO .OR. XT.GT.SIX .OR. YT.LT.ZERO .OR. YT.GT.SIX) 00589600
     $        JSKIP = I                                                 00589700
          IF ( JSKIP.EQ.I ) WRITE(6,207)                                00589800
          IF (JSKIP.EQ.I) GO TO 1560                                    00589900
C                PLOT THE POINT                                         00590000
          CALL SYMBOL (XT,YT,.05,1HX,0.,1)                              00590100
 1560   CONTINUE                                                        00590200
C                CLOSE UNIT PLOT, RESTORE ZEROS                         00590300
        CALL PLOT (7.3,-2.5,-3)                                         00590400
 1570   CONTINUE                                                        00590500
        GO TO 4000                                                      00590600
 1600 CALL PLOT(1.0,.4,-3)                                              00590700
        ISW=0                                                           00590800
        RD=RSMAX/TEN                                                    00590900
C                WAS MAX RADIUS SPECIFIED                               00591000
        IF (RD.EQ.ZERO) GO TO 1630                                      00591100
        ISW=1                                                           00591200
        GO TO 1640                                                      00591300
C                IF NO MAX SPECIFIED, SCALE GRAPH                       00591400
 1630   EPP(1)=ZERO                                                     00591500
        EPP(2)=XW(NTHRU)                                                00591600
        RSMAX=EPP(4)*TEN                                                00591700
C                EPP(4) IS ADJUSTED INCREMENT                           00591800
        RD=EPP(4)                                                       00591900
 1640 CALL SCALE(EPP(1),10.,2,2)                                        00592000
C          HEAD RED PLOT                                                00592100
      IF (UFLAG.EQ.ONE) GO TO 1650                                      00592200
      IF (UFLAG.EQ.TWO) GO TO 1660                                      00592300
      IF (UFLAG.EQ.THREE) GO TO 1670                                    00592400
      IF (UFLAG.EQ.FOUR) GO TO 1690                                     00592500
      GO TO 1680                                                        00592600
 1650 CALL AXIS(0.,10.,MSGU,-21,10.,270.,RD,DIV)                        00592700
      GO TO 1700                                                        00592800
 1660 CALL AXIS(0.,10.,MSGK,-21,10.,270.,RD,DIV)                        00592900
      GO TO 1700                                                        00593000
 1670 CALL AXIS(0.,10.,MSGJ,-16,10.,270.,RD,DIV)                        00593100
      GO TO 1700                                                        00593200
 1680 CALL AXIS(0.,10.,MSGX,-15,10.,270.,RD,DIV)                        00593300
      GO TO 1700                                                        00593400
 1690 CALL AXIS(0.,10.,MSG1,-16,10.,270.,RD,DIV)                        00593500
 1700 CALL AXIS(0.,10.,MSGL,14,5.,0.,20.,DIV)                           00593600
      CALL PLOT(0.,10.,3)                                               00593700
 1710 DO 1720 I=1,40                                                    00593800
       IPL=I*.025*TIMES                                                 00593900
       XT=I*.125                                                        00594000
       YT=TEN-(RP(IPL))/RD                                              00594100
       IF (YT.LT.ZERO) GO TO 1720                                       00594200
C          PLOT 40 POINTS                                               00594300
       CALL PLOT(XT,YT,2)                                               00594400
 1720 CONTINUE                                                          00594500
      CALL SYMBOL(6.65,9.2,.2,MSGP,-90.,17)                             00594600
      YP=5.8                                                            00594700
      DO 1725 I=1,25                                                    00594800
         INDD=I+80                                                      00594900
         CALL SYMBOL(6.7,YP,.2,NAME(INDD),-90.,1)                       00595000
         YP=YP-.2                                                       00595100
 1725 CONTINUE                                                          00595200
      CALL SYMBOL(6.25,8.4,.14,MSGQ,-90.,28)                            00595300
      CALL NUMBER(6.25,4.5,.14,HTNX,-90.,6)                             00595400
      CALL SYMBOL(6.25,3.3,.14,MSGR,-90.,3)                             00595500
      CALL NUMBER(6.25,2.8,.14,HTNY,-90.,6)                             00595600
C          CLOSE RED PLOT                                               00595700
      CALL PLOT(7.5,-.4,-3)                                             00595800
      IF (ISW.EQ.0) RSMAX=0.                                            00595900
      GO TO 4000                                                        00596000
 1800 CALL PLOT(1.0,.4,-3)                                              00596100
      CALL AXIS(0.,10.,MSGM,-41,10.,270.,0.,DELTPL,DIV)                 00596200
      CALL AXIS(0.,10.,MSGN,8,5.,0.,0.,.2,DIV)                          00596300
      CALL PLOT(0.,10.,3)                                               00596400
      DO 1810 K=1,51                                                    00596500
      EN=(K-1)*DELTEN                                                   00596600
      XT=TX(K)*FIVE                                                     00596700
      YT=TEN-EN*DELTCC                                                  00596800
C            PLOT MTF VALUES                                            00596900
      CALL PLOT(XT,YT,2)                                                00597000
 1810 CONTINUE                                                          00597100
      CALL SYMBOL(6.65,9.2,.2,MSGO,-90.,17)                             00597200
      YP=5.8                                                            00597300
      DO 1820 I=1,25                                                    00597400
        INDD=I+80                                                       00597500
        CALL SYMBOL(6.7,YP,.2,NAME(INDD),-90.,1)                        00597600
        YP=YP-.2                                                        00597700
 1820 CONTINUE                                                          00597800
      CALL SYMBOL(6.25,8.4,.14,MSGQ,-90.,28)                            00597900
      CALL NUMBER(6.25,4.5,.14,HTNX,-90.,6)                             00598000
      CALL SYMBOL(6.25,3.3,.14,MSGR,-90.,3)                             00598100
      CALL NUMBER(6.25,2.8,.14,HTNY,-90.,6)                             00598200
C          CLOSE PLOT                                                   00598300
      CALL PLOT(7.5,-.4,-3)                                             00598400
      IF (ISW.EQ.1) SMAX=0                                              00598500
      GO TO 4000                                                        00598600
 2000 CALL PLOTS(53,0,10)                                               00598700
C           SET BLOCKSIZE = 1024 FOR ZETA ERROR CORRECTION MODE         00598800
C           AT 1200 BAUD, M256 = 2 FOR 300 BAUD ERROR CORRECTION MODE   00598900
      M256=IFOUR                                                        00599000
      CALL ZETOBS(M256)                                                 00599100
      GO TO 4000                                                        00599200
 3000 CALL PLOT(0.,0.,999)                                              00599300
 4000 CONTINUE                                                          00599400
      RETURN                                                            00599500
      END                                                               00599600
C                                                                       00599700
C******************************************************                 00599800
      SUBROUTINE FNDSPT                                                 00599900
C******************************************************                 00600000
C                ROUTINE SPOT PERFORMS SPOT PLOT AND PRINT              00600100
C                CALCULATIONS                                           00600200
      IMPLICIT REAL *8 (A-H,O-Z)                                        00600300
      INTEGER *4 OPTNA,OPTNB,OPTNC,OPTND,OPTNE,OPTNF,OPTNG,ANULI,SECTRS 00600400
C                                                                       00600500
      COMMON /PMATX/  TRASH(10),S,D,RHO,UFLAG,RNOBJ,HYINIT,HYDEL,HXINIT,00600600
     $                HXDEL,APSTOP,SMAX,RSMAX,FOCL,OBJN(3),DELIMP,      00600700
     $                FPLANE,FAKEA,C(40),T(40),R(40),CONIC(40),FN(40,3),00600800
     $                FMASK(40),FAKEC(40),FAKEB(40),XDISP(40),YDISP(40),00600900
     $                TILTX(40),TILTY(40),TILTZ(40),ORDN(40,3),SIDE(40),00601000
     $                RDSPAC(40),Y0(40),SXY(40),SXNU(40),COEF(40,4),    00601100
     $                XMN(40),XMX(40),YMN(40),YMX(40),RX(40),CX(40),    00601200
     $                FREF(40),FREF0,WAVL(3)                            00601300
      COMMON /COLLAT/ CLTRA(300),RADIMG,CVIMG,CONIMG,NPLANE,LATYPE,     00601400
     $                ICOL(3),NCOL,NSURF,IMODE,IPRINT,IPLTPR,IWVFLG(3), 00601500
     $                IPR20,IREF,IJK,IALLPL                             00601600
      COMMON /HEAD/   LINES,IPAGE,NSYS,LAMDA,NAME(160)                  00601700
      COMMON /PUPIL/  ENPUPR,ENPUPL,EXPUPR,EXPUPL                       00601800
      COMMON /SAGPAR/ YMAX,YMIN,DELY,REFCRV,CONST,WAVENM,ISRF           00601900
      COMMON /CRED/ RPP(40),EPP(40),XW(812),HYSAVE,HXSAVE,              00602000
     $             TIMES,RD,OPTNE,ISW,IOPB                              00602100
      COMMON /CMTF/   AN,RSC,DELTEN,DELTPL,DELTCC,                      00602200
     $                AR(40),DE(40),EN,SUM,AJ,TX(51),OPTNF,IOPC         00602300
      COMMON /CSPOT/  XTMAX,XTMIN,YTMAX,YTMIN,AVGX,AVGY,RP(812),SPOTP,  00602400
     $                XK(812),YK(812),XKALL(7600),YKALL(7600),JSKIP,    00602500
     $                IOPA,NTHRU                                        00602600
C                                                                       00602700
C                                                                       00602800
C                                                                       00602900
      DIMENSION YW(812),TOR(40)                                         00603000
      DIMENSION ZF(10),BLOB(10)                                         00603100
      DIMENSION XSUM(10),YSUM(10),XSUMSQ(10),YSUMSQ(10)                 00603200
      DIMENSION QT(3),XX(3),XYZ(3)                                      00603300
C                                                                       00603400
      EQUIVALENCE (QT(1),QX),(QT(2),QY),(QT(3),QZ)                      00603500
      EQUIVALENCE (XX(1),XT),(XX(2),YT),(XX(3),ZT)                      00603600
      EQUIVALENCE (XYZ(1),X),(XYZ(2),Y),(XYZ(3),Z)                      00603700
      EQUIVALENCE (TRASH(1),XSMIN),(TRASH(2),XSMAX),(TRASH(3),YSMIN)    00603800
      EQUIVALENCE (TRASH(4),YSMAX),(TRASH(5),FCODE),(TRASH(6),FXYJ)     00603900
      EQUIVALENCE (TRASH(7),FXY),(TRASH(8),FXNU),(TRASH(9),FBY)         00604000
      EQUIVALENCE (TRASH(10),FBNU),(Y0(1),TOR(1))                       00604100
C                                                                       00604200
C                                                                       00604300
      DATA IZERO/0/,IONE/1/                                             00604400
      DATA ZERO/0.D0/,ONE/1.D0/,TWO/2.D0/,THREE/3.D0/,FOUR/4.D0/        00604500
      DATA FIVE/5.D0/,SIX/6.D0/,TEN/10.D0/,HUNDRD/100.D0/,THOUS/1000.D0/00604600
      DATA EPS1/1.D-9/,EPS2/1.D-14/,PI/3.141592653589793D0/             00604700
C                                                                       00604800
C                                                                       00604900
        CALL GRAPH(2,1)                                                 00605000
        IF (ISW.EQ.1) GO TO 1580                                        00605100
        XSMIN=ZERO                                                      00605200
        YSMIN=ZERO                                                      00605300
        XSMAX=ZERO                                                      00605400
        YSMAX=ZERO                                                      00605500
 1580  RETURN                                                           00605600
       END                                                              00605700
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00605800
C                                                                       00605900
C     SUBROUTINE BESJN(X,N,BJN,ERRA, IER)                               00606000
C                                                                       00606100
C                                                                       00606200
C                                                                       00606300
C    PURPOSE                                                            00606400
C        COMPUTE THE ORDINARY                                           00606500
C        BESSEL FUNCTIONS OF ORDER N                                    00606600
C              J (X)                                                    00606700
C               N                                                       00606800
C                                                                       00606900
C    USAGE                                                              00607000
C         CALL BESJN (X, N, BJN, ERRA, IER)                             00607100
C                                                                       00607200
C    PARAMETERS                                                         00607300
C         BJN  - VALUE OF BESSEL FUNCTION                               00607400
C         ERRA - ACCURACY                                               00607500
C         IER  - ERROR FLAG                                             00607600
C              = 1 => FATAL ERROR BESJN COULD NOT ACHIEVE DESIRED       00607700
C                     PRECISION                                         00607800
C                                                                       00607900
C         N    - ORDER                                                  00608000
C         X    - ARGUMENT                                               00608100
C                                                                       00608200
C    METHOD                                                             00608300
C         USING THE RATIO X/DFLOAT(N)                                   00608400
C         BESJN DIRECTS THE CALCULATION TO ONE OF 3 SUBROUTINES         00608500
C     X/N < 0.50  => CALL BESJN0 FOR SUMMATION OF ASCENDING SERIES      00608600
C     X/N > 100. => CALL BESJN1 FOR SUMMATION OF ASYMPTOTIC SERIES      00608700
C      OTHERWISE  => CALL BESJN2 FOR DOWNWARDS RECURSION                00608800
C                                                                       00608900
C                                                                       00609000
C                                                                       00609100
C                                                                       00609200
C    WRITTEN 4/12/84 BY JOHN PARKER OF SSAI UNDER CONTRACT WITH         00609300
C    GSFC.                                                              00609400
C                                                                       00609500
C    REFERENCE: ABRAMOWITZ AND STEGUN, HANDBOOK OF MATHEMATICAL         00609600
C                FUNCTIONS (NATIONAL BUREAU OF STANDARDS)               00609700
C                                                                       00609800
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00609900
      SUBROUTINE BESJN(X,N,BJN,ERRA, IER)                               00610000
      IMPLICIT REAL*8 (A-H, O-Z)                                        00610100
      DATA ERRMIN/1.D-13/, ZERO/0.0D0/, ONE/1.0D0/                      00610200
      DATA TEN/10.0D0/                                                  00610300
C                                                                       00610400
      IER = 0                                                           00610500
      IER2 = 0                                                          00610600
      IER1 = 0                                                          00610700
      BJN = ZERO                                                        00610800
      ERR = DABS(ERRA)                                                  00610900
      IF(ERR .LE. ERRMIN) ERR= ERRMIN                                   00611000
C                                                                       00611100
C        DETERMINE PHASE                                                00611200
C                                                                       00611300
        PHASE = ONE                                                     00611400
      IF(((X .LT. ZERO) .OR. (N .LT. 0)) .AND.                          00611500
     A   (MOD(N,2) .NE. 0)) PHASE = -ONE                                00611600
      IF ((X .LT. ZERO) .AND. (N.LT.0)) PHASE = ONE                     00611700
C                                                                       00611800
C        CHANGE INPUT VBL NAME SO INPUT NOT DESTROYED                   00611900
C                                                                       00612000
      XA  = DABS(X)                                                     00612100
      NA  = IABS(N)                                                     00612200
      DNA1= DFLOAT(NA+1)                                                00612300
C                                                                       00612400
C        CHECK FOR SPECIAL VALUES                                       00612500
C                                                                       00612600
      IF( XA .GT. ZERO) GO TO 10                                        00612700
C                                                                       00612800
C         SPECIAL VALUES FOR X = 0                                      00612900
C                                                                       00613000
      BJN = ZERO                                                        00613100
      IF( NA .EQ. 0) BJN = ONE                                          00613200
      GO TO 50                                                          00613300
C                                                                       00613400
   10  CONTINUE                                                         00613500
       TEST = XA/DNA1                                                   00613600
       IF(TEST   .LE. 0.50D0) GO TO 20                                  00613700
       IF(TEST   .GE. 1.D02 ) GO TO 30                                  00613800
   12  CALL BESJN2 (XA, NA, BJN, ERR, IER)                              00613900
       IF(IER .EQ. 0) GO TO 50                                          00614000
       IF( (IER2.NE.0) .OR. (IER3.NE.0)) GO TO 40                       00614100
C                                                                       00614200
C    DOWNWARDS RECURSION FAILED TO CONVERGE.  TRY ASCENDING OR          00614300
C    ASYMPTOTIC SERIES                                                  00614400
C                                                                       00614500
       IF(TEST.LE.ONE) GO TO 20                                         00614600
       IF(TEST.GT.TEN) GO TO 30                                         00614700
       GO TO 40                                                         00614800
   20  CALL BESJN0(XA, NA, BJN, ERR, IER2)                              00614900
       IF(IER2.EQ.0) GO TO 50                                           00615000
       IF(IER.EQ.0) GO TO 12                                            00615100
       IER = IER2                                                       00615200
       GO TO 40                                                         00615300
   30  CALL BESJN1(XA, NA, BJN, ERR, IER3)                              00615400
       IF(IER3.EQ.0) GO TO 50                                           00615500
       IF(IER.EQ.0) GO TO 12                                            00615600
       IER = IER3                                                       00615700
       GO TO 40                                                         00615800
   40  WRITE(6,10010) IER, X, N                                         00615900
10010  FORMAT(/,' BESJN: ERROR. FAILURE TO CONVERGE',/                  00616000
     A          ' BESJN:                 ERROR FLAG IER = ',I5,         00616100
     B        /,' BESJN:',20X,'(X, N) =    ',1PD15.6,I5,/)              00616200
   50  RETURN                                                           00616300
       END                                                              00616400
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC            00616500
      SUBROUTINE BESJN0 (X, N, BJN, ERR, IER)                           00616600
      IMPLICIT REAL*8 (A-H, O-Z)                                        00616700
      DATA ZERO/0.0D0/, ONE/1.0D0/                                      00616800
C                                                                       00616900
C       USE ASCENDING SERIES FOR SMALL ARGUMENTS                        00617000
C                                                                       00617100
      IF(IER .EQ. 100) WRITE(6, 1)                                      00617200
 1    FORMAT(10X,' BESSEL FUNCTION ROUTINE: ASCENDING SERIES',          00617300
     A //, ' NUM. ', '   TERM VALUE  ', '          SUM  '/)             00617400
           M= 0                                                         00617500
           XHALF = X/2.0D0                                              00617600
           Y     = -XHALF*XHALF                                         00617700
           DN    = DFLOAT(N)                                            00617800
           DN1   = DFLOAT(N+1)                                          00617900
           TERM  = ONE                                                  00618000
           BJN   = TERM                                                 00618100
   20 IF(M.GT.500) GO TO 50                                             00618200
              M=M+1                                                     00618300
              DM = DFLOAT(M)                                            00618400
              TERM  = TERM * Y /(DM*(DM + DN))                          00618500
              BJN = BJN + TERM                                          00618600
              IF(DABS(TERM/BJN).GT.ERR) GO TO 20                        00618700
      IF(N.EQ.0) GO TO 40                                               00618800
      ATMP = ONE                                                        00618900
      DO 30 I=1,N                                                       00619000
          DI = DFLOAT(I)                                                00619100
          ATMP = ATMP * (XHALF/DI)                                      00619200
   30 CONTINUE                                                          00619300
      BJN = BJN * ATMP                                                  00619400
   40 RETURN                                                            00619500
   50 IER = M                                                           00619600
      RETURN                                                            00619700
      END                                                               00619800
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC                00619900
      SUBROUTINE BESJN1 (X, N, BJN, ERR, IER)                           00620000
      IMPLICIT REAL*8 (A-H, O-Z)                                        00620100
      DATA ZERO/0.0D0/, ONE/1.0D0/                                      00620200
      DATA PI/3.141592653589793238462643D0/                             00620300
C                                                                       00620400
C     ASYMPTOTIC SERIES FOR BJN                                         00620500
C                                                                       00620600
      PHASE = ONE                                                       00620700
       DN   = DFLOAT(N)                                                 00620800
       DMU = DN*DN *4.0D0                                               00620900
       EIGHTX = 8.0D0*X                                                 00621000
       KTEST =  (N+N+1)/4                                               00621100
       TERM = ONE                                                       00621200
       P= ONE                                                           00621300
       Q = ZERO                                                         00621400
       K = 0                                                            00621500
  230  K=K+1                                                            00621600
          OLDTRM = TERM                                                 00621700
          DK = DFLOAT(K)                                                00621800
          TERM = TERM*(DMU-(DK+ONE)*(DK+ONE))/(DK*EIGHTX)               00621900
          IF(MOD(K,2) .NE.0) GO TO 120                                  00622000
            PHASE = -PHASE                                              00622100
            P = P + PHASE * TERM                                        00622200
          GO TO 130                                                     00622300
C                                                                       00622400
C                                                                       00622500
  120     Q = Q + PHASE*TERM                                            00622600
          GO TO 130                                                     00622700
  130 CONTINUE                                                          00622800
C     WRITE(6,131) K,TERM,P,Q                                           00622900
C 131 FORMAT('  K,TERM,P,Q=',I5,1P3D20.10,/)                            00623000
      IF(K.LT.KTEST) GO TO 230                                          00623100
      IF(P.NE.ZERO) ATMP = DABS(TERM/P)                                 00623200
      IF(P.EQ.ZERO) ATMP = DABS(TERM)                                   00623300
      IF ((ATMP .GT. ERR)                                               00623400
     A       .AND.(DABS(TERM) .LT. DABS(OLDTRM)))GO TO 230              00623500
C                                                                       00623600
C                                                                       00623700
C                                                                       00623800
      IF(DABS(TERM).GT.DABS(OLDTRM)) GO TO 140                          00623900
C                                                                       00624000
C    ASYMPTOTIC SERIES SUCCESSFULLY CONVERGED                           00624100
C                                                                       00624200
       CHI = X - (DN +DN+ONE)*PI*0.25D0                                 00624300
       BJN = P*DCOS(CHI)-Q*DSIN(CHI)                                    00624400
       BJN = BJN*DSQRT(2.0D0/(X *PI))                                   00624500
       RETURN                                                           00624600
C                                                                       00624700
C   ASYMPTOTIC SERIES FAILED TO CONVERGE                                00624800
C                                                                       00624900
 140   IF(K.LT.KTEST) GO TO 230                                         00625000
       IER = 1                                                          00625100
       RETURN                                                           00625200
       END                                                              00625300
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      00625400
C                                                                       00625500
C     SUBROUTINE BESJN2(X,N,BJN,ERRA, IER)                              00625600
C                                                                       00625700
C                                                                       00625800
C                                                                       00625900
C    PURPOSE                                                            00626000
C        COMPUTE THE ORDINARY                                           00626100
C        BESSEL FUNCTIONS OF ORDER N                                    00626200
C              J (X)      BY DOWNWARDS RECURSION                        00626300
C               N                                                       00626400
C                                                                       00626500
C    USAGE                                                              00626600
C         CALL BESJN (X, N, BJN, ERRA, IER)                             00626700
C                                                                       00626800
C    PARAMETERS                                                         00626900
C         BJN  - VALUE OF BESSEL FUNCTION                               00627000
C         ERRA - ACCURACY                                               00627100
C         IER  - ERROR FLAG                                             00627200
C              = 1 => FATAL ERROR BESJN COULD NOT ACHIEVE DESIRED       00627300
C                     PRECISION                                         00627400
C              =100=> DETAILED PRINTS                                   00627500
C         N    - ORDER                                                  00627600
C         X    - ARGUMENT                                               00627700
C                                                                       00627800
C    METHOD                                                             00627900
C        STARTING AT A LARGE ORDER, RECUR DOWNWARDS                     00628000
C              USING                                                    00628100
C      K (X) = 2*(N+1)*K   (X)/X - K(X)                                 00628200
C       NN+1N+2                                                         00628300
C                                                                       00628400
C      THE K'S ARE EQUAL TO J'S WITHIN A CONSTANT FACTOR DETERMINED BY  00628500
C       DNORM = K  + 2*(K  + K  + . . . )                               00628600
C                0       2    4                                         00628700
C                                                                       00628800
C      THEN  J  = K  /DNORM                                             00628900
C             N    N                                                    00629000
C                                                                       00629100
C    WRITTEN 4/12/84 BY JOHN PARKER OF SSAI UNDER CONTRACT WITH         00629200
C    GSFC.                                                              00629300
C                                                                       00629400
C    REFERENCE: ABRAMOWITZ AND STEGUN, HANDBOOK OF MATHEMATICAL         00629500
C                FUNCTIONS (NATIONAL BUREAU OF STANDARDS)               00629600
C                                                                       00629700
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00629800
      SUBROUTINE BESJN2 (X, N, BJN, ERR, IER)                           00629900
      IMPLICIT REAL*8 (A-H, O-Z)                                        00630000
      DATA ZERO/0.0D0/, ONE/1.0D0/                                      00630100
C                                                                       00630200
      BJN    = ZERO                                                     00630300
      BSAVE  = ZERO                                                     00630400
      NSTART = MAX0(N + 10, IDINT(X + 10.0D0) )                         00630500
      ICHECK = 0                                                        00630600
C                                                                       00630700
C FOR A GIVEN NSTART, THIS LOOP IS PASSED THROUGH TWICE                 00630800
C    TO CHECK ERRORS                                                    00630900
C                                                                       00631000
   40 M = NSTART                                                        00631100
      DNORM  = ZERO                                                     00631200
         BJMP1 = ZERO                                                   00631300
         BJMP2 = ZERO                                                   00631400
         BJM   = 1.D-28                                                 00631500
C               RECURSION                                               00631600
   50    IF(M .LE. 0) GO TO 60                                          00631700
              M=M-1                                                     00631800
              DM = DFLOAT(M)                                            00631900
C  C                                                                    00632000
              BJMP2 = BJMP1                                             00632100
              BJMP1 = BJM                                               00632200
C  C                                                                    00632300
              BJM   =(2.0D0 * (DM+ONE ) * BJMP1/X)- BJMP2               00632400
C                                                                       00632500
              IF (M.EQ. N) BJN = BJM                                    00632600
              IF (MOD(M,2).NE.0) GO TO 50                               00632700
              IF (M .NE. 0) DNORM = BJM + DNORM + BJM                   00632800
              IF (M .EQ. 0) DNORM = BJM + DNORM                         00632900
          GO TO 50                                                      00633000
C                NORMALIZE                                              00633100
   60         BJN = BJN/DNORM                                           00633200
              IF( ICHECK.EQ.1) GO TO 70                                 00633300
                 ICHECK = 1                                             00633400
                 BSAVE = BJN                                            00633500
                 NSTART = NSTART + 2                                    00633600
                 GO TO 40                                               00633700
C                                                                       00633800
C          ACCURATE???                                                  00633900
C                                                                       00634000
   70        IF(DABS(BSAVE-BJN) .LE. DABS(BJN*ERR)) GO TO 90            00634100
C                                                                       00634200
C           TRY AGAIN                                                   00634300
C                                                                       00634400
   80            BSAVE = BJN                                            00634500
                 ICHECK = 1                                             00634600
                 NSTART = NSTART  + 5                                   00634700
                 IF(NSTART-N  .LT. 100 ) GO TO 40                       00634800
C                                                                       00634900
C       FATAL  ERROR TRAP                                               00635000
C                                                                       00635100
                     IER = NSTART                                       00635200
   90 RETURN                                                            00635300
      END                                                               00635400
